客服电话
APP下载
迪恩网络APP
随时随地掌握行业动态
官方微信
扫描二维码
关注迪恩网络微信公众号
|
See Also : Article_4724.asp - (Freeform Excel Worksheet)
This class will produce an Excel Spreadsheet from a TDataSet. No OLE is required or Excel Installation needed to create the file. The one problem with Excel OLE is that is tends to be rather Sloooow. The class uses standard Delphi I/O functions and is considerably faster than the OLE calls. Example. var XL : TDataSetToExcel; begin XL := TDataSetToExcel.Create(MyQuery,'c:\temp\test.xls'); XL.WriteFile; XL.Free; end; The columns are neatly sized, Numerics are formatted in "Courier" and obey "###,###,##0.00" for floats and "0" for integers. Dates are formatted "dd-MMM-yyyy hh:nn:ss". Column headers are in Bold and are boxed and shaded.
unit MahExcel;
interface uses Windows, SysUtils, DB, Math; // ============================================================================= // TDataSet to Excel without OLE or Excel required // // For a good reference on Excel BIFF? file format see site // http://sc.openoffice.org/excelfileformat.pdf // // Mike Heydon Dec 2002 // ============================================================================= type // TDataSetToExcel TDataSetToExcel = class(TObject) protected procedure WriteToken(AToken : word; ALength : word); procedure WriteFont(const AFontName : string; AFontHeight, AAttribute : word); procedure WriteFormat(const AFormatStr : string); private FRow : word; FDataFile : file; FFileName : string; FDataSet : TDataSet; public constructor Create(ADataSet : TDataSet; const AFileName : string); function WriteFile : boolean; end; // ----------------------------------------------------------------------------- implementation const // XL Tokens XL_DIM = $00; XL_BOF = $09; XL_EOF = $0A; XL_DOCUMENT = $10; XL_FORMAT = $1E; XL_COLWIDTH = $24; XL_FONT = $31; // XL Cell Types XL_INTEGER = $02; XL_DOUBLE = $03; XL_STRING = $04; // XL Cell Formats XL_INTFORMAT = $81; XL_DBLFORMAT = $82; XL_XDTFORMAT = $83; XL_DTEFORMAT = $84; XL_TMEFORMAT = $85; XL_HEADBOLD = $40; XL_HEADSHADE = $F8; // ======================== // Create the class // ======================== constructor TDataSetToExcel.Create(ADataSet : TDataSet; const AFileName : string); begin FDataSet := ADataSet; FFileName := ChangeFileExt(AFilename,'.xls'); end; // ==================================== // Write a Token Descripton Header // ==================================== procedure TDataSetToExcel.WriteToken(AToken : word; ALength : word); var aTOKBuffer : array [0..1] of word; begin aTOKBuffer[0] := AToken; aTOKBuffer[1] := ALength; Blockwrite(FDataFile,aTOKBuffer,SizeOf(aTOKBuffer)); end; // ==================================== // Write the font information // ==================================== procedure TDataSetToExcel.WriteFont(const AFontName : string; AFontHeight,AAttribute : word); var iLen : byte; begin AFontHeight := AFontHeight * 20; WriteToken(XL_FONT,5 + length(AFontName)); BlockWrite(FDataFile,AFontHeight,2); BlockWrite(FDataFile,AAttribute,2); iLen := length(AFontName); BlockWrite(FDataFile,iLen,1); BlockWrite(FDataFile,AFontName[1],iLen); end; // ==================================== // Write the format information // ==================================== procedure TDataSetToExcel.WriteFormat(const AFormatStr : string); var iLen : byte; begin WriteToken(XL_FORMAT,1 + length(AFormatStr)); iLen := length(AFormatStr); BlockWrite(FDataFile,iLen,1); BlockWrite(FDataFile,AFormatStr[1],iLen); end; // ==================================== // Write the XL file from data set // ==================================== function TDataSetToExcel.WriteFile : boolean; var bRetvar : boolean; aDOCBuffer : array [0..1] of word; aDIMBuffer : array [0..3] of word; aAttributes : array [0..2] of byte; i : integer; iColNum, iDataLen : byte; sStrData : string; fDblData : double; wWidth : word; begin bRetvar := true; FRow := 0; FillChar(aAttributes,SizeOf(aAttributes),0); AssignFile(FDataFile,FFileName); try Rewrite(FDataFile,1); // Beginning of File WriteToken(XL_BOF,4); aDOCBuffer[0] := 0; aDOCBuffer[1] := XL_DOCUMENT; Blockwrite(FDataFile,aDOCBuffer,SizeOf(aDOCBuffer)); // Font Table WriteFont('Arial',10,0); WriteFont('Arial',10,1); WriteFont('Courier New',11,0); // Column widths for i := 0 to FDataSet.FieldCount - 1 do begin wWidth := (FDataSet.Fields[i].DisplayWidth + 1) * 256; if FDataSet.FieldDefs[i].DataType = ftDateTime then inc(wWidth,2000); if FDataSet.FieldDefs[i].DataType = ftDate then inc(wWidth,1050); if FDataSet.FieldDefs[i].DataType = ftTime then inc(wWidth,100); WriteToken(XL_COLWIDTH,4); iColNum := i; BlockWrite(FDataFile,iColNum,1); BlockWrite(FDataFile,iColNum,1); BlockWrite(FDataFile,wWidth,2); end; // Column Formats WriteFormat('General'); WriteFormat('0'); WriteFormat('###,###,##0.00'); WriteFormat('dd-mmm-yyyy hh:mm:ss'); WriteFormat('dd-mmm-yyyy'); WriteFormat('hh:mm:ss'); // Dimensions WriteToken(XL_DIM,8); aDIMBuffer[0] := 0; aDIMBuffer[1] := Min(FDataSet.RecordCount,$FFFF); aDIMBuffer[2] := 0; aDIMBuffer[3] := Min(FDataSet.FieldCount - 1,$FFFF); Blockwrite(FDataFile,aDIMBuffer,SizeOf(aDIMBuffer)); // Column Headers for i := 0 to FDataSet.FieldCount - 1 do begin sStrData := FDataSet.Fields[i].DisplayName; iDataLen := length(sStrData); WriteToken(XL_STRING,iDataLen + 8); WriteToken(FRow,i); aAttributes[1] := XL_HEADBOLD; aAttributes[2] := XL_HEADSHADE; BlockWrite(FDataFile,aAttributes,SizeOf(aAttributes)); BlockWrite(FDataFile,iDataLen,SizeOf(iDataLen)); if iDataLen > 0 then BlockWrite(FDataFile,sStrData[1],iDataLen); aAttributes[2] := 0; end; // Data Rows while not FDataSet.Eof do begin inc(FRow); for i := 0 to FDataSet.FieldCount - 1 do begin case FDataSet.FieldDefs[i].DataType of ftBoolean, ftWideString, ftFixedChar, ftString : begin sStrData := FDataSet.Fields[i].AsString; iDataLen := length(sStrData); WriteToken(XL_STRING,iDataLen + 8); WriteToken(FRow,i); aAttributes[1] := 0; BlockWrite(FDataFile,aAttributes,SizeOf(aAttributes)); BlockWrite(FDataFile,iDataLen,SizeOf(iDataLen)); if iDataLen > 0 then BlockWrite(FDataFile,sStrData[1],iDataLen); end; ftAutoInc, ftSmallInt, ftInteger, ftWord, ftLargeInt : begin fDblData := FDataSet.Fields[i].AsFloat; iDataLen := SizeOf(fDblData); WriteToken(XL_DOUBLE,15); WriteToken(FRow,i); aAttributes[1] := XL_INTFORMAT; BlockWrite(FDataFile,aAttributes,SizeOf(aAttributes)); BlockWrite(FDataFile,fDblData,iDatalen); end; ftFloat, ftCurrency, ftBcd : begin fDblData := FDataSet.Fields[i].AsFloat; iDataLen := SizeOf(fDblData); WriteToken(XL_DOUBLE,15); WriteToken(FRow,i); aAttributes[1] := XL_DBLFORMAT; BlockWrite(FDataFile,aAttributes,SizeOf(aAttributes)); BlockWrite(FDataFile,fDblData,iDatalen); end; ftDateTime : begin fDblData := FDataSet.Fields[i].AsFloat; iDataLen := SizeOf(fDblData); WriteToken(XL_DOUBLE,15); WriteToken(FRow,i); aAttributes[1] := XL_XDTFORMAT; BlockWrite(FDataFile,aAttributes,SizeOf(aAttributes)); BlockWrite(FDataFile,fDblData,iDatalen); end; ftDate : begin fDblData := FDataSet.Fields[i].AsFloat; iDataLen := SizeOf(fDblData); WriteToken(XL_DOUBLE,15); WriteToken(FRow,i); aAttributes[1] := XL_DTEFORMAT; BlockWrite(FDataFile,aAttributes,SizeOf(aAttributes)); BlockWrite(FDataFile,fDblData,iDatalen); end; ftTime : begin fDblData := FDataSet.Fields[i].AsFloat; iDataLen := SizeOf(fDblData); WriteToken(XL_DOUBLE,15); WriteToken(FRow,i); aAttributes[1] := XL_TMEFORMAT; BlockWrite(FDataFile,aAttributes,SizeOf(aAttributes)); BlockWrite(FDataFile,fDblData,iDatalen); end; end; end; FDataSet.Next; end; // End of File WriteToken(XL_EOF,0); CloseFile(FDataFile); except bRetvar := false; end; Result := bRetvar; end; end. |
2023-10-27
2022-08-15
2022-08-17
2022-09-23
2022-08-13
六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期
今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知
今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道
今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要
我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多
今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不
电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很
我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法
今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win
今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎
请发表评论