一个通用的查询程序(试用)
*这个程序是应用软件中的一个过程，只要打开数据表，就可以对任意结构的数据表实现查询，与库结构完全无关，运行环境：win xp/VFP6.0。*浮动型F、整型I、双精度型B不能被type函数正确识别，只能识别为N型数据，按N型数据处理。
private all
set escape off
set status off
set scoreboard off
set talk off
set menus off
set exact on
set safety off
set color to +7/1
clear
jhh=1
do while jhh<=fcount(1)
if field(jhh)="轮次"
set color to +7/1
clear
jgzdh=messagebox("当前库发现[轮次]字段，是否切除[轮次]字段继续运行?",4+32+0,"条件查询")
if jgzdh=6
*alter改变库结构后，记录指针回到1号记录。
alter table dbf() drop column 轮次
exit
else
wait "[轮次]字段未切除，不能运行本程序." window at 16,52 nowait
tdsj=inkey(1.5)
wait clear
return
endif
endif
jhh=jhh+1
enddo
if upper(right(dbf(1),10))="LSCFZK.DBF"
jgzdh=messagebox("在LSCFZK库中运行本程序将覆盖其现有的数据，"+chr(13)+"是否备份LSCFZK库现有的数据?",4+32+0,"条件查询")
if jgzdh=6
xspxkm=space(40)
define windows win1 from 11,11 to 19,88 system title "LSCFZK库数据备份" color scheme 1
activate windows win1
move windows win1 center
@3,8 say "请输入新的数据库名：" get xspxkm pict '@A' valid trim(xspxkm)<>"".and.(.not."LSCFZK"$upper(xspxkm)) color ,+6/4
set cursor on
read
set cursor off
clear gets
release windows win1
if upper(right(trim(xspxkm),4))<>".DBF"
xspxkm=trim(xspxkm)+".dbf"
endif
if file(xspxkm)
clear
fgfh=messagebox("["+xspxkm+"]文件已存在,覆盖?",4+32+256,"文件覆盖")
if fgfh=6
copy to &xspxkm
else
clear
wait "目标文件未覆盖,未进行数据备份." window at 16,52 nowait
tdsj=inkey(1)
wait clear
endif
else
copy to &xspxkm
endif
endif
else
*
endif
dimension name2(300),cmop(300),adta(300),bjf(300),meti(300)
bjf(1)="$"
bjf(2)="="
bjf(3)=">"
bjf(4)="<"
bjf(5)=">="
bjf(6)="<="
bjf(7)="<>"
qzkg=0
qxh=1
do while qxh<=fcount()
if len(field(qxh))>qzkg
store len(field(qxh)) to qzkg
endif
qxh=qxh+1
enddo
qxh=1
do while qxh<=fcount()
if int((14-qzkg)/2)=(14-qzkg)/2
store space((14-qzkg)/2)+field(qxh)+space(14-len(field(qxh))-(14-qzkg)/2) to meti(qxh)
else
store space((14-qzkg-1)/2)+field(qxh)+space(14-len(field(qxh))-(14-qzkg-1)/2) to meti(qxh)
endif
qxh=qxh+1
enddo
cxkm=dbf(1)
copy structure to lsbjczk
sele 2
*alter改变库结构后，记录指针回到1号记录。
alter table lsbjczk add column 轮次 N(10)
use
sele 1
store 1 to t1,x3
qxh=1
ydlh1=1
jhdh1=1
inqxh=1
jhh=1
=afields(fac)
do while x3<>2
set color to +7/1,+6/4
clear
@24,12 say "PgUp键上页 PgDn键下页 ↑键上一字段 ↓键下一字段 Enter键确认"
@2,6.7 clear to 20,24
set color to +7/6
@2,6.7 clear to 20,24
@2,6.7 to 20,24
@3,10 say "请选择字段"
set color to +7/3,+6/4
@5,8 clear to 19.4,22.7
cxhh=1
if fcount()>14
if qxh>14
do while ydlh1<=qxh
if ydlh1=qxh
@cxhh+4,8 prompt meti(ydlh1)
else
@cxhh+4,8 say meti(ydlh1)
endif
cxhh=cxhh+1
ydlh1=ydlh1+1
enddo
else
do while ydlh1<=14
if ydlh1=jhdh1
@cxhh+4,8 prompt meti(ydlh1)
else
@cxhh+4,8 say meti(ydlh1)
endif
cxhh=cxhh+1
ydlh1=ydlh1+1
enddo
endif
else
do while ydlh1<=fcount()
if ydlh1=jhdh1
@cxhh+4,8 prompt meti(ydlh1)
else
@cxhh+4,8 say meti(ydlh1)
endif
cxhh=cxhh+1
ydlh1=ydlh1+1
enddo
endif
keyboard chr(13)
menu to jhdh1
do while .t.
anke=inkey(0)
do case
case anke=5.and.qxh>1.and.qxh<=fcount()
qxh=qxh-1
case anke=5.and.qxh=1
qxh=fcount()
case anke=24.and.qxh>=1.and.qxh<fcount()
qxh=qxh+1
case anke=24.and.qxh=fcount()
qxh=1
case anke=3
if qxh+13<=fcount()
qxh=qxh+13
else
qxh=fcount()
endif
case anke=18
if qxh-13>=1
qxh=qxh-13
else
qxh=1
endif
endcase
if qxh>14
ydlh=qxh-13
jhdh=14
else
ydlh=1
jhdh=qxh
endif
ydlh1=ydlh
jhdh1=jhdh
cxhh=1
set color to +7/3,+6/4
@5,8 clear to 19.4,22.7
if fcount()>14
if qxh>14
do while ydlh<=qxh
if ydlh=qxh
@cxhh+4,8 prompt meti(ydlh)
else
@cxhh+4,8 say meti(ydlh)
endif
cxhh=cxhh+1
ydlh=ydlh+1
enddo
else
do while ydlh<=14
if ydlh=jhdh
@cxhh+4,8 prompt meti(ydlh)
else
@cxhh+4,8 say meti(ydlh)
endif
cxhh=cxhh+1
ydlh=ydlh+1
enddo
endif
else
do while ydlh<=fcount()
if ydlh=jhdh
@cxhh+4,8 prompt meti(ydlh)
else
@cxhh+4,8 say meti(ydlh)
endif
cxhh=cxhh+1
ydlh=ydlh+1
enddo
endif
keyboard chr(13)
menu to jhdh
x1=qxh
name2(t1)=field(x1)
tt=type(name2(t1))
if tt="M".or.tt="G"
set color to +7/1
@22,10 say "记忆型/通用型字段不能用于条件查询"
loop
endif
if anke=13
exit
endif
enddo
if tt='C'.or.tt='N'.or.tt='D'.or.tt='Y'.or.tt='T'
@2,27.7 clear to 20,45
set color to +7/6
@2,27.7 clear to 20,45
@2,27.7 to 20,45
@3,30 say "请选择比较符"
set color to +7/3,+6/4
inanke=0
do while .t.
@5,29 clear to 19.4,43.7
incxhh=1
do while incxhh<=7
if inqxh=incxhh
@incxhh+4,29 prompt space(7)+bjf(incxhh)+space(7-len(bjf(incxhh)))
else
@incxhh+4,29 say space(7)+bjf(incxhh)+space(7-len(bjf(incxhh)))
endif
incxhh=incxhh+1
enddo
keyboard chr(13)
menu to x2
inanke=inkey(0)
do case
case inanke=5.and.inqxh>1.and.inqxh<=7
inqxh=inqxh-1
case inanke=5.and.inqxh=1
inqxh=7
case inanke=24.and.inqxh>=1.and.inqxh<7
inqxh=inqxh+1
case inanke=24.and.inqxh=7
inqxh=1
endcase
if inanke=13
exit
endif
enddo
else
@2,27.7 clear to 20,45
set color to +7/6
@2,27.7 clear to 20,45
@2,27.7 to 20,45
@3,29 say "请选择逻辑条件"
set color to +7/3,+6/4
inanke=0
inqxh=1
do while .t.
@5,29 clear to 19.4,43.7
do case
case inqxh=1
@5,29 prompt " 正条件 "
@6.2,29 say " 反条件 "
case inqxh=2
@5,29 say " 正条件 "
@6.2,29 prompt " 反条件 "
endcase
keyboard chr(13)
menu to x2
inanke=inkey(0)
do case
case inanke=5.and.inqxh>1.and.inqxh<=2
inqxh=inqxh-1
case inanke=5.and.inqxh=1
inqxh=2
case inanke=24.and.inqxh>=1.and.inqxh<2
inqxh=inqxh+1
case inanke=24.and.inqxh=2
inqxh=1
endcase
if inanke=13
exit
endif
enddo
endif
x2=inqxh
cmop(t1)=iif(tt<>"L",bjf(x2),iif(x2=1,'','.not.'))
do case
case tt="C"
adta(t1)=space(14)
case tt="N".or.tt="Y"
nagdxs=name2(t1)
adta(t1)=&nagdxs
case tt="D"
adta(t1)=date()
case tt="T"
adta(t1)=dtot(date())
endcase
if tt<>"L"
@2,48 clear to 20,84
set color to +7/6
@2,48 clear to 20,84
@2,48 to 20,84
@3,58 say "请输入查询数据"
set color to +7/6,+6/4
if cmop(t1)<>"$"
@5,51 say name2(t1)+cmop(t1) get adta(t1)
else
adta(t1)=space(10)
do case
case tt="N".or.tt="Y"
@5,62 say "$str("+name2(t1)+",19,"+ltrim(str(fac(x1,4)))+")"
case tt="D"
@5,62 say "$dtoc("+name2(t1)+")"
case tt="T"
@5,62 say "$ttoc("+name2(t1)+")"
case tt="C"
@5,62 say "$"+name2(t1)
endcase
@5,51 get adta(t1)
endif
set cursor on
read
set cursor off
clear gets
endif
set color to +7/1,+6/4
clear
if cmop(t1)<>"$"
do case
case tt="N".or.tt="Y"
adta(t1)=name2(t1)+cmop(t1)+ltrim(str(adta(t1),19,fac(x1,4)))
case tt="D"
adta(t1)=name2(t1)+cmop(t1)+"ctod("+[']+dtoc(adta(t1))+[']+")"
case tt="T"
adta(t1)=name2(t1)+cmop(t1)+"ctot("+[']+ttoc(adta(t1))+[']+")"
case tt="C"
do case
case .not."'"$adta(t1)
adta(t1)='chrtranc('+trim(name2(t1))+",' ','')"+cmop(t1)+[']+chrtranc(adta(t1),' ','')+[']
case .not.'"'$adta(t1)
adta(t1)="chrtranc("+trim(name2(t1))+'," ","")'+cmop(t1)+["]+chrtranc(adta(t1)," ","")+["]
case (.not.'['$adta(t1)).and.(.not.']'$adta(t1))
adta(t1)=[chrtranc(]+trim(name2(t1))+',[ ],[])'+cmop(t1)+'['+chrtranc(adta(t1),[ ],[])+']'
otherwise
adta(t1)="chrtranc("+trim(name2(t1))+'," ","")'+cmop(t1)+["]+"'”[]不能同用"+["]
messagebox("'、”与[]共存，程序运行结果可能不正确.",0,"警告")
endcase
case tt="L"
adta(t1)=cmop(t1)+name2(t1)
endcase
else
do case
case tt="N".or.tt="Y"
adta(t1)=[']+trim(adta(t1))+[']+"$str("+name2(t1)+",19,"+ltrim(str(fac(x1,4)))+")"
case tt="D"
adta(t1)=[']+trim(adta(t1))+[']+"$dtoc("+name2(t1)+")"
case tt="T"
adta(t1)=[']+trim(adta(t1))+[']+"$ttoc("+name2(t1)+")"
case tt="C"
do case
case .not."'"$adta(t1)
adta(t1)=[']+chrtranc(adta(t1),' ','')+[']+"$chrtranc("+name2(t1)+",' ','')"
case .not.'"'$adta(t1)
adta(t1)=["]+chrtranc(adta(t1)," ","")+["]+'$chrtranc('+name2(t1)+'," ","")'
case (.not.'['$adta(t1)).and.(.not.']'$adta(t1))
adta(t1)="["+chrtranc(adta(t1),[ ],[])+"]"+"$chrtranc("+name2(t1)+",[ ],[])"
otherwise
adta(t1)=["]+"'”[]不能同用"+["]+'$chrtranc('+name2(t1)+'," ","")'
messagebox("'、”与[]共存，程序运行结果可能不正确.",0,"警告")
endcase
endcase
endif
dat=adta(t1)
set color to +7/1
clear
if upper(right(cxkm,10))<>"LSCFZK.DBF"
copy to lscfzk for &dat
use lscfzk
else
copy to lsbjpxk for &dat
use lsbjpxk
endif
wa="本次查询:"+dat+"("+ltrim(str(RECCOUNT()))+"条)"
wait wa window at 16,(120-len(wa))/2 nowait
brow
use lsbjczk
if upper(right(cxkm,10))<>"LSCFZK.DBF"
append from lscfzk
else
append from lsbjpxk
endif
replace all 轮次 with jhh for 轮次=0
use
use &cxkm
set color to +7/1,+6/4
clear
x3=messagebox("继续进行条件查询?",4+32+0,"数据查询")
do case
case x3=6
x3=1
case x3=7
x3=2
otherwise
clear
wait "程序发生错误,返回." window at 16,48 nowait
return
endcase
jhh=jhh+1
enddo
use lsbjczk
copy to lscfzk
use lscfzk
jgzdh=messagebox("历次查询结果存于LSCFZK.DBF库，进行后续数据处理？",4+32+256,"条件查询")
if jgzdh=6
brow
endif
use &cxkm
erase lsbjczk.dbf
erase lsbjczk.fpt
erase lsbjpxk.dbf
erase lsbjpxk.fpt
clear
*set exact off
set menus on
set color to +7/1
clear
use
return
