FUNCTION dbf2excel(cExcelfilename,cDbfname,cSheetname,cFields,cFilter)
********************************************************
* cExcelfilename：C,带完整路径的EXCEL文件全名，abc.xlsx
* cDbfname: C,数据文件名
* cSheetname: C，工作表名字，可空
* cFields: C,"class 班级,name 姓名,math 数学"
* cFilter: C，数据过滤条件，可空
********************************************************
cFields = EVL(cFields,'*')
cSheetname = EVL(cSheetname,'')
cFilter = EVL(cFilter,'1=1')
LOCAL sc,arr[1],vbsCode,aFieldInfo[1],nStep,xnewfile,xtmpfile,i,xfile,j,k
IF EMPTY(JUSTPATH(cExcelfilename))
cExcelfilename = SYS(5) + SYS(2003) + '\' + alltrim(cExcelfilename)
ENDIF
xfile = cDbfname
sc = CREATEOBJECT("ScriptControl")
sc.Language = "VBScript"
TEXT TO vbsCode TEXTMERGE NOSHOW PRETEXT 7
dim oExcel,oRange, nRows, nCols, nCol,cExcelname
set oExcel = CREATEOBJECT("Excel.Application")
function Open(cExcelname,cSheetname,nNew)
if nNew=0 then ' 新建
oExcel.Workbooks.Add
oExcel.ActiveWorkbook.saveas cExcelname
else '已有
oExcel.Workbooks.Open(cExcelname)
oExcel.ActiveWorkbook.Worksheets.Add
end if
if cSheetname<>"" then
oExcel.Activesheet.name = cSheetname
end if
end function
function SetFormat(aFieldInfo, nRows)
for nCol=1 to UBound(aFieldInfo,1)
oExcel.Range(oExcel.Cells(1,nCol),oExcel.Cells(nRows,nCol)).Select
oExcel.Selection.NumberFormatLocal = aFieldInfo(nCol,8)
next
end function
function Append(vfpArray, nRow)
nRows = UBound(vfpArray,1)
nCols = UBound(vfpArray,2)
oExcel.Range(oExcel.Cells(nRow,1),oExcel.Cells(nRow+nRows-1,nCols)).Value = vfpArray
end function
function Close(nRows, nCols)
IF nRows>0 then
oExcel.Range(oExcel.Cells(1,1),oExcel.Cells(nRows,nCols)).Columns.AutoFit
end if
oExcel.Cells(1,1).select
oExcel.ActiveWorkbook.save
oExcel.quit
end function
function Show(nRows, nCols)
oExcel.Range(oExcel.Cells(1,1),oExcel.Cells(nRows,nCols)).Columns.AutoFit
oExcel.Visible = 1
end function
ENDTEXT
sc.AddCode(vbsCode)
WAIT '正在导出：'+cExcelfilename+' - '+ cSheetname WINDOW NOWAIT NOCLEAR
* 是否新建EXCEL文件
xnewfile = IIF(file(cExcelfilename),1,0)
sc.Run("Open", cExcelfilename,cSheetname,xnewfile)
* 表头数组
xtmpfile = SYS(2015)
SELECT &cFields FROM &xfile WHERE &cFilter INTO CURSOR &xtmpfile READWRITE
DIMENSION arr[1,FCOUNT(xtmpfile)]
* 字段类型
SELECT &xtmpfile
AFIELDS(aFieldInfo)
FOR i=1 TO ALEN(aFieldInfo,1)
arr[1,i] = aFieldInfo[i,1]
aFieldInfo[i,8] = ICASE(;
INLIST(aFieldInfo[i,2],"C","V","W","M"),'@',;
aFieldInfo[i,2]=="D", 'yyyy-m-d',; && 日期格式
aFieldInfo[i,2]=="T", 'yyyy-m-d hh:mm:ss',; && 日期时间格式
'')
ENDFOR
* 各列格式
sc.Run("SetFormat", @aFieldInfo, RECCOUNT(xtmpfile)+1)
* 插入表头
sc.Run("Append", @arr, 1)
* 表体
SELECT &xtmpfile
nStep = 10000
FOR i=1 TO RECCOUNT(xtmpfile) STEP nStep
SELECT * FROM &xtmpfile WHERE BETWEEN(RECNO(),i,i+nStep-1) INTO ARRAY arr
FOR j=1 TO ALEN(aFieldInfo,1)
IF aFieldInfo[j,2]='C'
FOR k=1 TO alen(arr,1)
arr[k,j] = alltrim(arr[k,j])
ENDFOR
ENDIF
ENDFOR
sc.Run("Append", @arr, i+1)
ENDFOR
sc.Run("Close",RECCOUNT(xtmpfile),FCOUNT(xtmpfile))
USE IN &xtmpfile
*sc.Run("Show",RECCOUNT(xfile),FCOUNT(xfile))
WAIT CLEAR
RETURN
用法示例：
LOCAL xfilename,xfile,xfield
xfilename = '学生名册'+'.XLSX'
xfile = thisform.grid1.RecordSource
xfield = 'bh 班号,xh 学号,xm 姓名,xb 性别,math 数学'
IF FILE(xfilename)
DELETE FILE &xfilename
ENDIF
dbf2excel(xfilename,xfile,'学生名册',xfield)
LOCAL xfilename,xfile,xfield,xtmpfile,xbj,xfilt
xfilename = '学生名册-按班'+'.XLSX'
xfile = thisform.grid1.RecordSource
xfield = 'bh 班号,xh 学号,xm 姓名,xb 性别,math 数学'
IF FILE(xfilename)
DELETE FILE &xfilename
ENDIF
xtmpfile = SYS(2015)
SELECT distinct bh FROM &xfile INTO CURSOR &xtmpfile READWRITE
SELECT &xtmpfile
SCAN
xbh = bh
xfilt = "bh='&xbh'"
dbf2excel(xfilename,xfile,xbh+'班',xfield,xfilt)
ENDSCAN
USE IN &xtmpfile
最新回复