回复 42楼 antony521
楼主所主张的判定为“空”即不行代换的做法可能有问题，遇有多条“物资名称”时，我是将当前dbf记录复制到下一条记录中，再用excel表下一行的内容对“物资名称”等进行代换，如果遇“空”即不行代换，则有可能导致excel上一行的内容“残留”在下一条dbf记录中，而引发数据导入错误，因此，excel单元格是“空”也要代换，只不过要把不确定的“空”，变成具体的空字符、0或空日期。
为此，根据你所试之结果，我对源代码进行了优化，现贴上。上一次所贴源代码中的erase bj-ext.dbf和erase bj-ext.fpt是无用的文件，是我最早用传统方法构建库结构时用的中间库，后来改为sql语句，这两句也就没用了。
要从excel文件中读取数据，excel文件必须是打开的，我用的是前台运行方式，所以看得见，后台运行方式不可见，但实际还是打开的状态，我认为还是前台方式好些，至少能看见程序在动作，程序运行中不乱点鼠标就行了。
另外，如果程序运行中意外中断，要设法关闭内存已启动的excel程序，xp下是ctrl+alt+del三键，选中程序列表中的excel点结束程序，其它的系统参见指导手册。这样，程序才能在下一次运行中不出问题。
private all
set talk off
set scoreboard off
set status off
set safety off
set exact on
dimension jgfh(300)
store 10 to jgfh
set color to +7/1,+6/4
clear
cxh=getdir()
cxh=alltrim(cxh)
if cxh=""
clear
wait "未指定文件夹,不予导入." window at 16,50 nowait
tdsj=inkey(1)
return
endif
xjkm1=left(cxh,len(cxh)-1)
*以下程序段以递归法获取某一目录及其下所有子目录名(包括隐含)
Create Table lscfzk (bbnr c(120),wjcd n(10),wjrq d,wjshj c(10),wjsx c(6))
append blank
replace bbnr with xjkm1
wait "正在提取子目录,进度:0/0" window at 16,50 nowait
tdsj=inkey(0.2)
do while .not.eof()
wait "正在提取子目录,进度:"+ltrim(str(recno()))+"/"+ltrim(str(reccount())) window at 16,50 nowait
ttpk=recno()
xjkm1=alltrim(bbnr)+"\"
zdst=adir(fac,(xjkm1+"*.*"),"rashd")
if zdst<>0
*数组前2个单元所存为"."和".."
for upk=3 to zdst
fac(upk,1)=xjkm1+fac(upk,1)
endfor
append from array fac for alltrim(bbnr)<>".".and.alltrim(bbnr)<>"..".and."D"$wjsx
endif
go ttpk
skip
enddo
use
Create Table lsdata (文件名 c(254),所在路径 c(254),生成日期 d,生成时刻 c(8),文件大小 n(6,0),导入结果 c(20))
*xjkm1代表的文件名决定导入何种文件,这里只导入excel文档.
xjkm1="*.xls"
sele 1
use lscfzk
*以下程序段用于获取某一目录下所有的excel文档(包括隐含)
jdt=25
wait clear
go top
do while .not.eof()
gdhh=recno()*64.4/reccount()+25
@12,44 say "正在提取Excel文档目录,进度："+ltrim(str(recno()*100/reccount(),10,2))+"%
"
do while jdt<=gdhh
set color to +6/1
@13,jdt to 14,90 pen 2
jdt=jdt+0.1
set color to +7/1
enddo
jdt=jdt-0.1
tdsj=inkey()
if recno()/reccount()=1
tdsj=inkey(1)
endif
wady=trim(bbnr)+"\"+xjkm1
num=adir(fac,wady,"rashd")
spk=1
sele 2
use lsdata
do while spk<=num
if alltrim(fac(spk,1))<>".".and.alltrim(fac(spk,1))<>"..".and.(.not."D"$fac(spk,5))
append blank
replace 文件名 with fac(spk,1)
replace 所在路径 with lower(trim(a->bbnr))
replace 生成日期 with fac(spk,3)
replace 生成时刻 with fac(spk,4)
replace 文件大小 with fac(spk,2)
endif
spk=spk+1
enddo
sele 1
skip
enddo
use
sele 2
use
sele 1
Create Table lscfzk (项目名称 c(60),项目编号 c(16),合约编号 c(20),表单编号 c(20),到货日期 d,使用单位 c(10),项目负责人 c(10),物资名称 c(20),物资型号 c(30),数量 n(7,0),单位 c(4),品牌 c(16))
use
use lsdata
*以下程序段用于读取Excel文档
set color to +7/1
clear
wait "正在启动Excel软件并导入各个文档" window at 16,48 nowait
tdsj=inkey(0.5)
OleApp=CreateObject("Excel.application")
if type("OleApp")#"O"
wait clear
messagebox( "访问Excel失败！请检查是否正确安装Excel软件！",48,"没有安装Excel")
OleApp.Quit
release OleApp
use
return
endif
go top
sele 2
use lscfzk
sele 1
do while .not.eof()
xjkm1=trim(所在路径)+"\"+trim(文件名)
if trim(文件名)=""
replace 导入结果 with
"文件名为空,不能导入."
skip
loop
endif
OleApp.Caption ="正在处理第["+ltrim(str(recno()))+"]类文档，进度："+ltrim(str(recno()*100/reccount(),10,2))+"%"
*导入可用Excel打开的文档
if ".XLS"$upper(XJKM1).and.(.not."$"$xjkm1)
oleapp.application.workbooks.open(xjkm1)
OleApp.Visible =.t.
sele 2
append blank
pp=oleapp.Cells(2,3).Value
if isnull(pp)
pp=""
endif
replace 项目名称 with pp
pp=oleapp.Cells(3,3).Value
if isnull(pp)
pp=""
endif
replace 项目编号 with pp
pp=oleapp.Cells(4,3).Value
if isnull(pp)
pp=""
endif
replace 合约编号 with pp
pp=oleapp.Cells(2,8).Value
if isnull(pp)
pp=""
endif
replace 表单编号 with pp
pp=oleapp.Cells(4,16).Value
if isnull(pp)
pp=ctod("
/
/
")
endif
replace 到货日期 with pp
pp=oleapp.Cells(4,12).Value
if isnull(pp)
pp=""
endif
replace 使用单位 with pp
pp=oleapp.Cells(3,16).Value
if isnull(pp)
pp=""
endif
replace 项目负责人 with pp
xa=7
pp=oleapp.Cells(xa,4).Value
if isnull(pp)
pp=""
endif
replace 物资名称 with pp
pp=oleapp.Cells(xa,5).Value
if isnull(pp)
pp=""
endif
replace 物资型号 with pp
pp=oleapp.Cells(xa,6).Value
if isnull(pp)
pp=0
endif
replace 数量 with pp
pp=oleapp.Cells(xa,7).Value
if isnull(pp)
pp=""
endif
replace 单位 with pp
pp=oleapp.Cells(xa,8).Value
if isnull(pp)
pp=""
endif
replace 品牌 with pp
xa=xa+1
pp=oleapp.Cells(xa,5).Value
if isnull(pp)
pp=""
endif
do while .not."检验结论"$pp
scatter to aaa
append blank
gather from aaa
pp=oleapp.Cells(xa,4).Value
if isnull(pp)
pp=""
endif
replace 物资名称 with pp
pp=oleapp.Cells(xa,5).Value
if isnull(pp)
pp=""
endif
replace 物资型号 with pp
pp=oleapp.Cells(xa,6).Value
if isnull(pp)
pp=0
endif
replace 数量 with pp
pp=oleapp.Cells(xa,7).Value
if isnull(pp)
pp=""
endif
replace 单位 with pp
pp=oleapp.Cells(xa,8).Value
if isnull(pp)
pp=""
endif
replace 品牌 with pp
xa=xa+1
pp=oleapp.Cells(xa,5).Value
if isnull(pp)
pp=""
endif
enddo
sele 1
replace 导入结果 with
"导入成功"
else
replace 导入结果 with
"文件类型错误,不能导入."
endif
skip
enddo
go top
OleApp.Quit
release OleApp
clear
wait "以下是记录在lsdata库的Excel文档直读结果" at 16,50 windows nowait
brow
sele 2
wait "以下是保存在lscfzk库的Excel文档导入数据" at 16,50 windows nowait
brow
use
sele 1
return
[
本帖最后由 沙枣 于 2015-7-13 09:03 编辑 ]
测试1.rar
.
