將數(shù)據(jù)表的記錄輸出到EXCEL中去

Alkaid2015 2013-10-22

展開全文

FUNCTION GetValidFileName
PARAMETERS FileName
LOCAL sFileName
m.sFileName=ALLTRIM(FileName)
m.sFileName=STRTRAN(m.sFileName,\"[\",\" \")
m.sFileName=STRTRAN(m.sFileName,\"]\",\" \")
m.sFileName=STRTRAN(m.sFileName,\"\\\",\" \")
m.sFileName=STRTRAN(m.sFileName,\"/\",\" \")
m.sFileName=STRTRAN(m.sFileName,\"|\",\" \")
m.sFileName=STRTRAN(m.sFileName,\"?\",\" \")
m.sFileName=STRTRAN(m.sFileName,\"*\",\" \")
m.sFileName=STRTRAN(m.sFileName,\">\",\" \")
m.sFileName=STRTRAN(m.sFileName,\"<\",\" \")
m.sFileName=STRTRAN(m.sFileName,\":\",\" \")
m.sFileName=STRTRAN(m.sFileName,\'\"\',\' \')

m.sFileName=STRTRAN(m.sFileName,\'：\' , \'\')
m.sFileName=STRTRAN(m.sFileName,\',。\' , \'\')
m.sFileName=STRTRAN(m.sFileName,\',，\' , \'\')
m.sFileName=STRTRAN(m.sFileName,\'“\' , \'\')
m.sFileName=STRTRAN(m.sFileName,\'”\' , \'\')
m.sFileName=ALLTRIM(m.sFileName)
RETURN sFileName
ENDFUNC

*********************************************************************
*功能：將數(shù)據(jù)表的記錄輸出到EXCEL 中去,。
* SheetName ：Excel工作表名
* SheetTitle ：Excel數(shù)據(jù)標題
* DbfFile ：數(shù)據(jù)源
* ExcelFile ：Excel文件
* lNewXls ：創(chuàng)建還是添加到Excel文件中
* sBz ：備注內(nèi)容
*********************************************************************
function DbfToXls
parameter SheetName,SheetTitle,DbfFile,ExcelFile,lNewXls,sBz
local FileOpen,noldarea,oCdialog,OldError,FileName,ColdPath
ColdPath=sys(5)+sys(2003)
SheetName=GetValidFileName(alltrim(SheetName))
SheetTitle=GetValidFileName(alltrim(SheetTitle))
FileName=GetValidFileName(ExcelFile)
ExcelFile=GetValidFileName(ExcelFile+iif(upper(right(ExcelFile,4))<>\'.XLS\',\".XLS\",\"\"))
IF lNewXls AND NOT EMPTY(ExcelFile) OR NOT File(ExcelFile) &&如果是添加方式
oCdialog=NewOBJECT(\"mscomdlg.commondialog\")
*oCdialog=CREATEOBJECT(\"mscomdlg.commondialog\")
if type(\"oCdialog\")<>\"O\"
=messagebox( \"無法創(chuàng)建對象,！\", MB_OK+MB_ICONEXCLAMATION, ERRORTITLE_LOC)
return \"\"
endif
OldError=ON(\"ERROR\")
On ERROR oCdialog.FileName = \"\"
*oCdialog.CancelError=.t.
oCdialog.dialogTitle =SheetTitle
oCdialog.filter=\"Excel文檔(*.xls)|*.xls\"
oCdialog.MaxFileSize=20000
oCdialog.FileName=excelfile &&默認文件名
oCdialog.ShowSave()

ExcelFile=oCdialog.FileName
FileName=oCdialog.FileTitle
RELEASE oCdialog
On ERROR &OldError
endif
if !empty(ColdPath)
*set default to &ColdPath
endif
IF EMPTY(FileName)
RETURN \"\"
ENDIF
noldarea=select()
FileOpen=.T.
RetVal=.F.
excelfile=alltrim(excelfile)

dbffile=alltrim(dbffile)
dbfname=substr(dbffile,rat(\"\\\",dbffile)+1,len(dbffile)) &&獲得表名
if !used(dbfname)
if !file(dbffile)
=messagebox( \'數(shù)據(jù)文件：\'+dbffile+\"未找到,！\", MB_OK+MB_ICONEXCLAMATION, ERRORTITLE_LOC)
return \"\"
endif
use &dbffile in 0
FileOpen=.F.
endif
nRet=0

IF FILE(ExcelFile).and.lNewXls &&如果是創(chuàng)建文件,，則判斷是否存在原文件
nRet=messagebox( ExcelFile+chr(13)+\'已存在,，要替換該文件嗎,？ \', MB_YESNOCANCEL+MB_ICONEXCLAMATION+MB_DEFBUTTON2, TITLE_LOC )
do case
case nRet=IDYES
=DeleteFile(ExcelFile) &&利用API函數(shù)刪除文件
case nRet=IDCANCEL
return \"\"
endcase
endif

tmpsheet = GETOBJECT(\'\',\'excel.sheet\')
if .not.(type(\'tmpsheet\')=\'O\' ) && U 未能產(chǎn)生EXCEL對象
=messagebox( \' 創(chuàng)建報表失敗,！\' + CHR(13) + CHR(13) + ;
\'請檢查你的系統(tǒng)是否正確安裝 EXCEL 軟件,！\' , MB_OK+MB_ICONEXCLAMATION, ERRORTITLE_LOC)
select(noldarea)
return \"\"
endif

xlapp = tmpsheet.APPLICATION
xlapp.VISIBLE = .f.
***! 創(chuàng)建excel打印對象 *****------------------------------------------------------------------------------------
IF FILE(ExcelFile)
xlapp.WorkBooks.Open(ExcelFile)
SheetsCount= xlapp.Sheets.Count
i=1
do while i<=SheetsCount &&查找文件中所有工作表，判斷是否有相同的工作表
if upper(alltrim(xlapp.Sheets(i).name))= upper(alltrim(SheetName))
nRet=messagebox(\'“\'+ xlapp.Sheets(i).name+\'”工作表已經(jīng)存在,，要否刪除該工作表,？\', MB_YESNO+MB_ICONEXCLAMATION+MB_DEFBUTTON2, TITLE_LOC )
do case
case nRet=IDYES &&是：
xlapp.DisplayAlerts = .F. &&關(guān)閉警告提示
xlapp.ActiveWorkbook.Sheets(i).Delete &&刪除存在的工作表
xlapp.DisplayAlerts = .T. &&打開警告提示
SheetsCount=SheetsCount-1 &&減少一個工作表
case nRet=IDNO &&否：
xlapp.activeWorkbook.close(.f.)
xlapp.quit
xlapp=NULL
release xlapp,tmpsheet
return \"\" &&退出程序
endcase
else
i=i+1
EndIf
enddo
xlapp.Sheets.add()
Else
xlapp.workbooks.ADD()
endif
xlapp.ActiveWindow.WindowState = 2 && 最大化打開的工作本
xlsheet = xlapp.activesheet &&選中當前激活的表
IF EMPTY(SheetName)
if empty(SheetTitle)
xlsheet.name =DTOC(DATE())
else
enter=at(chr(13),SheetTitle)
if enter<>0
xlsheet.name =left(left(SheetTitle,enter),30)
else
xlsheet.name =left(SheetTitle,30)
endif
endif
ELSE
xlsheet.name =left(SheetName,30)
ENDIF
***! 創(chuàng)建excel打印對象 *****------------------------------------------------------------------------------------

loForm = CreateObject(\"Thermomet\",\"\",\"\") &&創(chuàng)建進度條
loForm.Show()
loForm.Update(1)

select &dbfname
FieldCount=fcount() &&當前表中的字段數(shù)
RecordCount=reccount() &&當前表中的記錄數(shù)
if empty(SheetTitle) &&如果沒有表頭，則從第一行開始,。
startline=1
else
startline=2
ENDIF

nFoot=IIF(EMPTY(m.sBz),0,2) &&頁腳是否有備注內(nèi)容

if Fieldcount>26
if mod(Fieldcount,26)<>0
ch1=chr(asc(\"A\")+(int(Fieldcount/26))-1)
ch2=chr(asc(\"A\")+(mod(Fieldcount,26))-1)
else
ch1=chr(asc(\"A\")+(int(Fieldcount/26)-1)-1)
ch2=\"Z\"
endif
ch=ch1+ch2
else
ch=chr(asc(\"A\")+Fieldcount-1)
endif
area=\"A\"+\":\"+ch
textarea=\"A\"+alltrim(str(startline))+\":\"+ch+alltrim(str(RecordCount+startline+nFoot)) &&alltrim(str(Fieldcount))
titlearea=\"A\"+alltrim(str(1))+\":\"+ch+alltrim(str(1))

if !empty(SheetTitle)
enter=at(chr(13),SheetTitle)
i=iif(enter=0,0,1)
do while enter<>0
if at(chr(13),SheetTitle,enter)<>0
i=i+1
else
exit
endif
enddo
xlsheet.range(titlearea).MergeCells=.t. &&合并單元格
xlsheet.Rows(\"1:1\").RowHeight =(i+1)*25
xlsheet.Rows(\"1:1\").font.size=16
xlsheet.Rows(\"1:1\").font.bold=.t.
xlsheet.rows(\"1:1\").shrinktofit=.t. &&自動收縮為適當尺寸有適應(yīng)有效列寬
xlsheet.Rows(\"1:1\").HorizontalAlignment = 3 && 水平方向: 2左對齊,3居中,4右對齊
xlsheet.Rows(\"1:1\").VerticalAlignment = 2 && 垂直方向: 1靠上,，2居中，3靠下
xlsheet.Cells( 1,1).VALUE=SheetTitle &&表標題
ENDIF

IF !EMPTY(sbz)
Footarea=\"A\"+alltrim(str(RecordCount+startline+1))+\":A\"+alltrim(str(RecordCount+startline+nFoot))
xlsheet.range(Footarea).MergeCells=.t. &&合并單元格
Footarea=\"B\"+alltrim(str(RecordCount+startline+1))+\":\"+ch+alltrim(str(RecordCount+startline+nFoot))
xlsheet.range(Footarea).MergeCells=.t. &&合并單元格
xlsheet.Cells(RecordCount+startline+1,1).VALUE=\"說明\" &&表標題
xlsheet.Cells(RecordCount+startline+1,2).VALUE=sbz &&表標題
ENDIF

*xlsheet.columns(textarea).entirecolumn.autofit
xlsheet.range(textarea).font.size=9 &&全部字體為9號字
xlsheet.range(textarea).WrapText = .t. &&自動換行

*xlsheet.range(textarea).shrinktofit=.t. &&自動收縮為適當尺寸有適應(yīng)有效列寬
xlsheet.range(textarea).Borders(1).Weight = 2 &&框線寬度： 2細線 3粗線
xlsheet.range(textarea).Borders(2).Weight = 2 &&框線寬度： 2細線 3粗線
xlsheet.range(textarea).Borders(3).Weight = 2 &&框線寬度： 2細線 3粗線
xlsheet.range(textarea).Borders(4).Weight = 2 &&框線寬度： 2細線 3粗線

for i=1 to fieldcount
*area=alltrim(str(startline))+\":\"+alltrim(str(i))
*fieldtype=type(field(i)) &&字段類型
*if fieldtype=\'N\'
* xlsheet.Rows(area).HorizontalAlignment = 4 && 水平方向: 2左對齊,3居中,4右對齊
*else
* xlsheet.Rows(area).HorizontalAlignment = 3 && 水平方向: 2左對齊,3居中,4右對齊
*endif
xlsheet.Cells( startline,i).HorizontalAlignment = 3 && 水平方向: 2左對齊,3居中,4右對齊
xlsheet.Cells( startline,i).VerticalAlignment = 2 && 垂直方向: 1靠上,，2居中,，3靠下
xlsheet.Cells( startline,i).VALUE=alltrim(field(i)) &&列標題（字段名字）
xlsheet.Cells( startline,i).font.color= RGB(0,0,255)
xlsheet.Cells( startline,i).Interior.color= RGB(192,192,192)

*xlsheet.Cells( startline,i).shrinktofit=.t. &&自動收縮為適當尺寸有適應(yīng)有效列寬

if i>26 &&列超過26列
if mod(i,26)<>0
ch1=chr(asc(\"A\")+(int(i/26))-1)
ch2=chr(asc(\"A\")+(mod(i,26))-1)
else
ch1=chr(asc(\"A\")+(int(i/26)-1)-1)
ch2=\"Z\"
endif
ch=ch1+ch2
else
ch=chr(asc(\"A\")+i-1)
endif
area=ch+\":\"+ch
xlsheet.columns(area).columnwidth=iif(len(field(i))>fsize(field(i)),len(field(i)),fsize(field(i))) &&得到列寬
if xlsheet.columns(area).columnwidth>16
*xlsheet.columns(area).columnwidth=16
*xlsheet.columns(area).HorizontalAlignment = 2 && 水平方向: 2左對齊,3居中,4右對齊
endif

*!* xlsheet.Cells(startline ,i).Borders(1).Weight = 2 &&框線寬度： 2細線 3粗線
*!* xlsheet.Cells(startline ,i).Borders(2).Weight = 2 &&框線寬度： 2細線 3粗線
*!* xlsheet.Cells(startline ,i).Borders(3).Weight = 2 &&框線寬度： 2細線 3粗線
*!* xlsheet.Cells(startline ,i).Borders(4).Weight = 2 &&框線寬度： 2細線 3粗線
endfor

loForm.ShowTitle(\"正在進行數(shù)據(jù)輸出，稍候（在此期間請勿執(zhí)行 Excel 程序）\")

go top
for i=1 to RecordCount
lcPercent = recn()/Reccount()*100
RetVal=loForm.Update(lcPercent)
if RetVal
exit
endif

for j=1 to FieldCount
fieldtype=type(field(j))
if fieldtype=\'C\'
xlsheet.Cells( i+startline,j).NumberFormatLocal=\'@\'
endif
*!* With Selection
*!* .HorizontalAlignment = xlGeneral
*!* .VerticalAlignment = xlBottom
*!* .WrapText = True
*!* .Orientation = 0
*!* .AddIndent = False
*!* .ShrinkToFit = False
*!* .MergeCells = False
*!* End With

fieldname=field(j)
IF NOT EMPTY(fieldname)
fvalue=&fieldname
IF INLIST(fieldtype,\"N\",\"D\",\"Y\",\"T\").and.empty(fvalue)
fvalue=\"\"
ENDIF
xlsheet.Cells( i+startline,j).VALUE=IIF(fieldtype<>\"L\",fvalue,IIF(fvalue,\"是\",\"否\")) &&字段內(nèi)容
IF INLIST(fieldtype,\"N\",\"Y\")
xlsheet.Cells( i+startline,j).HorizontalAlignment = 4 && 水平方向: 2左對齊,3居中,4右對齊
ELSE
xlsheet.Cells( i+startline,j).HorizontalAlignment = 3 && 水平方向: 2左對齊,3居中,4右對齊
ENDIF
xlsheet.Cells( i+startline,j).VerticalAlignment = 2 && 垂直方向: 1靠上,，2居中,，3靠下
IF iif(len(field(j))>fsize(field(j)),len(field(j)),fsize(field(j)))>20
xlsheet.Cells( i+startline,j).HorizontalAlignment = 2 && 水平方向: 2左對齊
ENDIF
ENDIF
ENDFOR
SKIP
IF EOF()
EXIT
ENDIF
ENDFOR
loForm.Update(100)
loForm.complete()

xlapp.ActiveWindow.SplitRow = 2 &&在第二行凍結(jié)窗口，即標題欄不滾動
xlapp.ActiveWindow.FreezePanes = .T.

xlapp.DisplayAlerts = .F. &&關(guān)閉警告提示
xlapp.activeWorkbook.SaveAs( excelfile )
xlapp.DisplayAlerts = .T. &&關(guān)閉警告提示
xlapp=tmpsheet.APPLICATION
xlapp.activeWorkbook.close(.f.)
xlapp.quit
xlapp=NULL
release xlapp

if !RetVal
*=messagebox( \" 已完成報表輸出\"+chr(13)+chr(13)+substr(excelfile,RAT(\"\\\",excelfile)+1)+;
* +chr(13)+chr(13)+\"已保存于 \"+SUBSTR(excelfile,1,RAT(\"\\\",excelfile));
* +\" 目錄中,！\", MB_OK+MB_ICONEXCLAMATION, TITLE_LOC)
wait \" 已完成報表輸出\"+chr(13)+chr(13)+substr(excelfile,RAT(\"\\\",excelfile)+1)+;
+chr(13)+chr(13)+\"已保存于 \"+SUBSTR(excelfile,1,RAT(\"\\\",excelfile));
+\" 目錄中,！\" windows nowait
endif
if !FileOpen &&如果當時表未打開，則退出時亦關(guān)閉
use in &dbfname
endif
*if !empty(ColdPath).and.directory(ColdPath)
* set default to &ColdPath
*endif
select(noldarea)
return excelfile &&返回保存的文件名
ENDFUNC