回复 楼主 antony521
根据楼主所给样本数据，本人用了两个半小时编制了针对性的EXCEL导入DBF程序，可以达到楼主的要求，在xp/vfp6.0下测试通过。
使用方法：在VFP下直接运行本程序，选中存放“检验报告”的文件夹即可，运行后形成两个数据表，lsdata表记录的是各个Excel文档是否导入成功（文档处理信息），lscfzk表记录的是楼主想要的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
erase bj-ext.dbf
erase bj-ext.fpt
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
replace 项目名称 with pp
pp=oleapp.Cells(3,3).Value
replace 项目编号 with pp
pp=oleapp.Cells(4,3).Value
replace 合约编号 with pp
pp=oleapp.Cells(2,8).Value
replace 表单编号 with pp
pp=oleapp.Cells(4,16).Value
replace 到货日期 with pp
pp=oleapp.Cells(4,12).Value
replace 使用单位 with pp
pp=oleapp.Cells(3,16).Value
replace 项目负责人 with pp
xa=7
pp=oleapp.Cells(xa,4).Value
replace 物资名称 with pp
pp=oleapp.Cells(xa,5).Value
replace 物资型号 with pp
pp=oleapp.Cells(xa,6).Value
replace 数量 with pp
pp=oleapp.Cells(xa,7).Value
replace 单位 with pp
pp=oleapp.Cells(xa,8).Value
replace 品牌 with pp
xa=xa+1
pp=oleapp.Cells(xa,5).Value
do while .not."检验结论"$pp
scatter to aaa
append blank
gather from aaa
pp=oleapp.Cells(xa,4).Value
replace 物资名称 with pp
pp=oleapp.Cells(xa,5).Value
replace 物资型号 with pp
pp=oleapp.Cells(xa,6).Value
replace 数量 with pp
pp=oleapp.Cells(xa,7).Value
replace 单位 with pp
pp=oleapp.Cells(xa,8).Value
replace 品牌 with pp
xa=xa+1
pp=oleapp.Cells(xa,5).Value
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
erase bj-ext.dbf
erase bj-ext.fpt
return
运行结果：
[
本帖最后由 沙枣 于 2015-7-12 14:34 编辑 ]
2015-07-10 19:19
结果.rar
(1.89 KB)
