Procedure tfrmzjmovesch.bitbtn2click (Sender: Tobject); var wd: twritedata; begin wd: = twritedata.create; wd.qry: = qryzjmovesch; wd.summary.add ('casting handover plan:'); wd.summary.add ( 'All production lots!'); Wd.summary.add ('create by:' frmmain.username); wd.summary.add (DateTostr (now)); Try if Savedialog1.execute dam.exporttofile (Savedialog1.FileName , true); finally WD.Free; end; // end; unit WriteData; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGridEh, DB, ADODB, StdCtrls, Buttons, XpMenu, DBGRIDS; // Target is: Export data by normal AdoQuery! // Create by yxf // Date: 2004-10-05 // type TColumnsList = class (TList) private function GetColumn (Index: Integer): TColumn; procedure SetColumn (Index: Integer; const Value: TColumn); public property Items [Index: Integer]: TColumn read GetColumn write SetColumn; default; end; TColCellParams = class protected FAlignment: TAlignment; FBackground: TColor; FCol: Longint; FFont: TFont; FImageIndex: Integer; FReadOnly: Boolean; FRow: Longint; fState: TGridDrawState; FText: String; public property Alignment: TAlignment read FAlignment write FAlignment; property Background: TColor read FBackground write FBackground; property Col: Longint read FCol; property Font: TFont read FFont; property ImageIndex: Integer read FImageIndex write FImageIndex; property ReadOnly : Boolean Read Freadonly Write FreadOnly; Property Row; Property State: TgriddrawState Read FState; Property Text: String Read Ftext Write Ftext; End; twritedata = class private // fcolcellparamseh: TcolcellParamseh;
FDBGrid: TCustomDBGrid; FQry: TAdoQuery; // FExpCols: TColumnsEhList; FStream: TStream; // function GetFooterValue (Row, Col: Integer): String; // procedure CalcFooterValues; FCol, FRow: Word; FSummary: TStringList; // FColumns : TColumnsList; // FCount: integer; // column sums protected // FooterValues: PFooterValues; procedure WriteBlankCell; procedure WriteEnter; procedure WriteIntegerCell (const AValue: Integer); procedure WriteFloatCell (const AValue: Double); procedure WriteStringCell (const AValue: String); procedure IncColRow; procedure WritePrefix; procedure WriteSuffix; procedure WriteTitle; procedure WriteRecord (ColumnsList: TColumnsList); procedure WriteDataCell (Column: TColumn; FColCellParams: TColCellParams); // procedure WriteFooter (ColumnsList: TColumnsEhList; FooterNo: Integer); / / Procedure Writefootercell (Datacol, Row: Integer; Column: Tcolumneh; AFONT: TFONT; // Background: Tcolor; ALIGNMENT: TALIGNMENT; Text: String); property Stream: TStream read FStream write FStream; // property ExpCols: TColumnsEhList read FExpCols write FExpCols; public constructor Create; destructor Destroy; override; procedure ExportToStream (AStream: TStream; IsExportAll: Boolean); procedure ExportToFile (FileName: String ; IsExportAll: Boolean); property Summary: TStringList read fSummary write fSummary; property Qry: TAdoQuery read FQry write FQry; property DBGrid: TCustomDBGrid read FDBGrid write FDBGrid; end; implementation {TWriteData} var CXlsBof: array [0..5] of Word = ($ 809, 8, 0, $ 10, 0, 0); CXLSeof: Array [0..1] of Word = ($ 0a, 00); cxlslabel: array [0..5] of word = ($ 204, 0, 0, 0, 0, 0);
CxlsNumber: Array [0..4] of Word = ($ 203, 14, 0, 0, 0); CXLSRK: Array [0..4] of Word = ($ 27E, 10, 0, 0, 0); CXLSBLANK : Array [0..4] of Word = ($ 201, 6, 0, 0, $ 17); Constructor TWRITA.CREATE; begin // fdbgrid: = tcustomDBGrid.create (self); fsummary: = tstringlist.create; inherited; end; destructor TWriteData.Destroy; begin FSummary.Free; inherited; end; procedure TWriteData.ExportToFile (FileName: String; IsExportAll: Boolean); var FileStream: TFileStream; begin FileStream: = TFileStream.Create (FileName, fmCreate); try ExportToStream (FileStream, IsExportAll); finally FileStream.Free; end; end; procedure TWriteData.ExportToStream (AStream: TStream; IsExportAll: Boolean); var // ColList: TColumnsEhList; BookMark: Pointer; i: Integer; begin FCol: = 0; Frow: = 0; stream: = astream; writeprefix; // Write the title Writetitle; Bookmark: = QRY.GetBookmark; QRY.DisableControls; screen.cursor: = crsqlwait; try.Cursor: = Crsqlwait; try.Pry qry.active dam qry.open; qry.first While NOT Qry. EOF Do Begin for i: = 0 to QRY.Fieldcount - 1 Do Begin Case QRY.Fields [i] .DataType of Ftsmallint, ftinteger, ftword, ftautoinc, ftbytes: WriteIntegercell (Qry.fields [i] .asinteger; ftfloat, FTCurrency, ftbcd {$ ifdef eh_lib_6}, ftfmtbcd {$ ENDIF}: WriteFloatcell (Qry.fields [i] .asfloat); Else WriteStringcell (Qry.fields [i] .sstring); end; end; QRY.NEXT; END; finally Qry.GotoBookmark (BookMark); Qry.EnableControls; Qry.FreeBookmark (BookMark); WriteEnter; WriteStringCell ( 'query:'); WriteEnter; for I: = 0 to FSummary.Count - 1 do begin if FSummary.Strings [ I] =
'# 13' TEN WRITEENTER ELSE WRITESTRINGCELL (FSummary.Strings [I]); WriteEnter; end; screen.cursor: = crdefault; end; Writesuffix; showMessage ('data import successfully completed!'); // Specific processing Export Settings END ; procedure TWriteData.IncColRow; begin if FCol = Qry.FieldCount - 1 then begin Inc (FRow); FCol: = 0; end else Inc (FCol); end; procedure TWriteData.WriteBlankCell; begin CXlsBlank [2]: = FRow; CXlsBlank [3]: = FCol; Stream.WriteBuffer (CXlsBlank, SizeOf (CXlsBlank)); IncColRow; end; procedure TWriteData.WriteDataCell (Column: TColumn; FColCellParams: TColCellParams); begin if Column.Field = nil then WriteBlankCell // else if Column.GetColumnType = ctKeyPickList then // WriteStringCell (FColCellParamsEh.Text) else if Column.Field.IsNull then WriteBlankCell else with Column.Field do case DataType of ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes: WriteIntegerCell (AsInteger); ftFloat, FTCurrency, FTBCD: Writefloatcell (asfloat); Else WriteStringCell (FColCellParams.Text); end; end; procedure TWriteData.WriteEnter; begin FCol: = Qry.FieldCount - 1; WriteStringCell ( ''); // FCol: = Qry.FieldCount - 1; end; procedure TWriteData.WriteFloatCell ( const AValue: Double); begin CXlsNumber [2]: = FRow; CXlsNumber [3]: = FCol; Stream.WriteBuffer (CXlsNumber, SizeOf (CXlsNumber)); Stream.WriteBuffer (AValue, 8); IncColRow; end; procedure TWriteData .Writeintegercell; var v: integer; begin cxlsrk [2]: = frow; cxlsrk [3]: = fcol; stream.writebuffer (Cxlsrk, sizeof (cxlsrk)); v: = (Avalue SHL 2 ) or 2; stream.writebuffer (V, 4); inccolrow; end; procedure twritedata.writeprefix;
begin Stream.WriteBuffer (CXlsBof, SizeOf (CXlsBof)); end; procedure TWriteData.WriteRecord (ColumnsList: TColumnsList); var // i: Integer; AFont: TFont; // State: TGridDrawState; begin AFont: = TFont.Create; Try // for i: = 0 to columnslist.count - 1 do begin // afont.assign (Columnslist [i] .font); // with tcolcellparamsehcracker (fcolcellparamseh) Do begin // fow: = -1; // fcol : = -1; // fState: = []; // fft: = AFONT; // background: = columnSlist [i] .color; // align: = columnslist [i] .alignment; // imageindex: = columnslist [i] .GetImageIndex; // Text: = ColumnsList [i] .DisplayName; // CheckboxState: = ColumnsList [i] .CheckboxState; // if Assigned (DBGridEh.OnGetCellParams) then // DBGridEh.OnGetCellParams (DBGridEh, ColumnsList [ I], ffont, fboground, fstate; // columnslist [i] .getcolcellparams (false, fcolcellparamseh); // WriteDataCell (ColumnList [i], fcolcellparamseh); end; end; Finally Afont.Free; End; End; Procedure TWRITA.WRITESTRINGE: String; var l: word; begin L: = Length (Avalue); cxlslabel [1]: = 8 L; CXLSLabel [2]: = FRow; CXlsLabel [3]: = FCol; CXlsLabel [5]: = L; Stream.WriteBuffer (CXlsLabel, SizeOf (CXlsLabel)); Stream.WriteBuffer (Pointer (AValue) ^, L); IncColRow; end; procedure TWriteData .Writesuffix; begin stream.writebuff (CXLSeof, Sizeof); End; Procedure TWRITA.WRITETITETITLE; VAR I: Integer; Begin // Refined // Traverse Columns Filling Title for i: = 0 to Qry. FieldCount - 1 Do Begin WriteStringcell (Qry.fields [i] .displayLabel); End; End;
