回复 10楼 TZTJ
你的问题可以用以下的程序解决,根据选定的“字段组合”,取每一种组合一条记录排列在一起,某一条件多余出来的记录,集中排在数据表最后。
使用方法:
打开数据表,do 程序1即可看到结果。
private all
set talk off
set status off
set scoreboard off
set exact on
set escape off
set safety off
set delete off
set confirm on
dimension name1(300),jgfh(300),meti(300)
dimension lydh(300)
ysbjkm=dbf(1)
recall all
if upper(right(dbf(),10))<>"LSDELE.DBF"
copy structure to lsdele
endif
jhh=1
do while jhh<=len(dbf(1))
if left(right(dbf(1),jhh),1)<>"\"
jhh=jhh+1
else
ysbjkm=lower(right(dbf(1),jhh-1))
exit
endif
enddo
zuhtij="recno()>=1"+space(130)
set color to +7/1,+6/4
clear
use &ysbjkm
qxh=1
do while qxh<=fcount()
store space(5)+field(qxh)+space(13-len(field(qxh))) to meti(qxh)
qxh=qxh+1
enddo
store space(5)+"选择结束"+space(5) to meti(qxh)
@23,7 say "PgUp键上页
PgDn键下页
↑键上一字段
↓键下一字段
Enter键确认"
@2,6.7 clear to 21,28
@2,30.7 clear to 21,52
@2,55 clear to 21,76
set color to +7/6
@2,6.7 clear to 21,28
@2,30.7 clear to 21,52
@2,55 clear to 21,76
@2,6.7 to 21,28
@2,30.7 to 21,52
@2,55 to 21,76
@3,10 say "请选择排序字段"
@3,37 say "排序方式"
@3,60 say "选中的字段有"
set color to +7/3,+6/4
@5,8 clear to 20.4,26.7
store 1 to pk,zd
store space(10) to name1
store "," to jgfh
qxh=1
zd=1
do while qxh<=fcount()+1.and.qxh<=15
if zd=qxh
@qxh+4,8 prompt meti(qxh)
else
@qxh+4,8 say meti(qxh)
endif
qxh=qxh+1
enddo
keyboard chr(13)
menu to zd
qxh=1
do while .t.
anke=inkey(0)
do case
case anke=5.and.qxh>1.and.qxh<=fcount()+1
qxh=qxh-1
case anke=5.and.qxh=1
qxh=fcount()+1
case anke=24.and.qxh>=1.and.qxh<fcount()+1
qxh=qxh+1
case anke=24.and.qxh=fcount()+1
qxh=1
case anke=3
if qxh+14<=fcount()+1
qxh=qxh+14
else
qxh=fcount()+1
endif
case anke=18
if qxh-14>=1
qxh=qxh-14
else
qxh=1
endif
endcase
if qxh>15
ydlh=qxh-14
jhdh=15
else
ydlh=1
jhdh=qxh
endif
cxhh=1
set color to +7/3,+6/4
@5,8 clear to 20.4,26.7
if fcount()>14
if qxh>15
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<=15
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()+1
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
zd=qxh
ozj=pk
sdh=0
do while ozj>=1
if field(zd)<>left(name1(ozj),len(field(zd)))
ozj=ozj-1
else
sdh=sdh+1
ozj=ozj-1
endif
enddo
if zd<>fcount()+1.and.sdh=0.and.anke=13
if type(field(zd))<>"L".and.type(field(zd))<>"M".and.type(field(zd))<>"G"
set color to +7/3,+6/4
inqxh=1
inanke=0
do while .t.
@5,32 clear to 20.4,50.7
do case
case inqxh=1
@5,32 prompt "
升
序
"
@6.2,32 say "
降
序
"
@7.4,32 say "
不分大小写
"
case inqxh=2
@5,32 say "
升
序
"
@6.2,32 prompt "
降
序
"
@7.4,32 say "
不分大小写
"
case inqxh=3
@5,32 say "
升
序
"
@6.2,32 say "
降
序
"
@7.4,32 prompt "
不分大小写
"
endcase
keyboard chr(13)
menu to xxh
inanke=inkey(0)
do case
case inanke=5.and.inqxh>1.and.inqxh<=3
inqxh=inqxh-1
case inanke=5.and.inqxh=1
inqxh=3
case inanke=24.and.inqxh>=1.and.inqxh<3
inqxh=inqxh+1
case inanke=24.and.inqxh=3
inqxh=1
endcase
if inanke=13
exit
endif
enddo
xxh=inqxh
do case
case xxh=1
store field(zd)+"/A" to name1(pk)
case xxh=2
store field(zd)+"/D" to name1(pk)
case xxh=3
store field(zd)+"/C" to name1(pk)
endcase
set color to +7/6,+6/4
@2,30.7 clear to 21,52
@2,30.7 to 21,52
@3,37 say "排序方式"
@5,32 say "
升
序
"
@6.2,32 say "
降
序
"
@7.4,32 say "
不分大小写
"
set color to +7/6,+6/4
if pk<=15.and.anke=13
@pk+4,60 say trim(name1(pk))
endif
if pk>15.and.anke=13
vehp=pk-14
inhm=1
do while vehp<=pk
@inhm+4,60 say space(14)
@inhm+4,60 say trim(name1(vehp))
vehp=vehp+1
inhm=inhm+1
enddo
endif
pk=pk+1
else
set color to +7/1
@25,23 say "记忆型/逻辑型/通用型字段不能作为排序条件"
endif
endif
if zd=fcount()+1.and.anke=13
exit
endif
set color to +7/1,+6/4
enddo
if zd=fcount()+1.and.anke=13.and.pk=1
set color to +7/6
@7,59 say "未 选 择 字 段"
@9,59 say "按第一个非L非G"
@11,59 say "和非M型字段为"
@13,59 say "排
序
条
件"
tdsj=inkey(1)
pkgd=1
do while pkgd<=fcount()
if type(field(pkgd))<>"L".and.type(field(pkgd))<>"M".and.type(field(pkgd))<>"G"
store field(pkgd)+"/A" to name1(pk)
pk=pk+1
exit
endif
pkgd=pkgd+1
enddo
endif
num=pk
dhzd=""
pk=1
if num=1
set color to +7/6
@5,56 clear to 19,75
@7,60 say "未找到合法的"
@9,60 say " 排序关键字"
@11,60 say " 返
回"
tdsj=inkey(2)
set color to +7/1
clear
use
loop
else
jgfh(num-1)=""
do while pk<num
dhzd=dhzd+name1(pk)+jgfh(pk)
pk=pk+1
enddo
endif
set color to +7/1
clear
define windows win1 from 2,3 to 28,97 system title "分层排序" color scheme 1
activate windows win1
move windows win1 center
zuhtij=trim(zuhtij)+space(132-len(trim(zuhtij)))
@8,40 say "请输入排序操作条件"
@1,1,23,13 box space(9)
@2,4 say "库字段"
@3,4 say "提
示"
@4,4 say "───"
pk=1
do while pk<=fcount().and.pk<=18
@pk+4,2 say field(pk)
pk=pk+1
enddo
@12,15 get zuhtij color ,+6/4
set cursor on
read
set cursor off
clear gets
release windows win1
set color to +7/1
clear
if trim(zuhtij)=""
wait "无条件将排序全部记录" window at 16,50 nowait
tdsj=inkey(1)
endif
clear
wait "正在进行分层排序" window at 16,50 nowait
if right(dhzd,1)=","
dhzd=left(dhzd,len(dhzd)-1)
endif
if trim(zuhtij)=""
sort to lsbjpxk on &dhzd
else
sort to lsbjpxk on &dhzd for &zuhtij
endif
use
use lsbjpxk
copy to st-ext structure extended
use st-ext
locate for upper(field_name)="LS_XH"
if found()
wait '表列名[LS_XH]与系统冲突' window at 16,50 nowait
use
erase st-ext.dbf
erase st-ext.fpt
erase lsbjpxk.dbf
erase lsbjpxk.fpt
return
endif
append blank
replace field_name with "ls_xh"
replace field_type with "N"
replace field_len with 10
create lspxczk from st-ext
append from lsbjpxk
dhbc=1
go top
do while .not.eof()
pk=1
store " " to jgfh
do while pk<num
nagdxs=left(trim(name1(pk)),len(trim(name1(pk)))-2)
store
&nagdxs to jgfh(pk)
pk=pk+1
enddo
replace ls_xh with 1
mvtep=recno(1)
if .not.eof()
skip
endif
do while .not.eof()
pk=1
qdpdh=0
do while pk<num
pdnadh=left(trim(name1(pk)),len(trim(name1(pk)))-2)
if &pdnadh<>jgfh(pk)
qdpdh=qdpdh+1
endif
pk=pk+1
enddo
if qdpdh=0
replace ls_xh with 1+(recno(1)-mvtep)*dhbc
skip
else
exit
endif
enddo
enddo
sort to lsysk on ls_xh
use
use st-ext
go bottom
delete
pack
create lsbjpxk from st-ext
append from lsysk
if upper(right(trim(ysbjkm),10))<>"LSCFZK.DBF"
copy to lscfzk
endif
clear
if upper(right(trim(ysbjkm),10))<>"LSCFZK.DBF"
wait "以下是数据层序的结果,已另存于lscfk库。" window at 16,40 nowait
else
wait "以下是数据层序的结果" window at 16,50 nowait
endif
brow
use
set color to +7/1
clear
erase st-ext.dbf
erase st-ext.fpt
erase lspxczk.dbf
erase lspxczk.fpt
erase lsysk.dbf
erase lsysk.fpt
return