Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- type
- TGeraCsv = class( TComponent )
- strict private
- FDataset: TDataSet;
- FCaminho : Ansistring;
- FNomeArquivo: Ansistring;
- procedure setFCaminho ( const Value: Ansistring );
- procedure GerarXlsx ( DataSet: TDataSet );
- public
- procedure Start;
- property Caminho : Ansistring read FCaminho write setFCaminho;
- property NomeArquivo: Ansistring read FNomeArquivo write FNomeArquivo;
- procedure AfterConstruction; override;
- procedure BeforeDestruction; override;
- constructor Create ( AOwner: TComponent; DataSet: TDataSet ); reintroduce; overload;
- procedure NativeXls;
- end;
- Implementation
- // Implementações do objeto
- { TGeraCsv }
- procedure TGeraCsv.AfterConstruction;
- begin
- inherited AfterConstruction;
- end;
- procedure TGeraCsv.BeforeDestruction;
- begin
- inherited BeforeDestruction;
- end;
- constructor TGeraCsv.Create ( AOwner: TComponent; DataSet: TDataSet );
- begin
- inherited Create ( AOwner );
- FDataset := DataSet;
- end;
- procedure TGeraCsv.GerarXlsx ( DataSet: TDataSet );
- var
- coluna, linha: Integer;
- excel : variant;
- valor : string;
- begin
- try
- excel := CreateOleObject ( 'Excel.Application' );
- excel.Workbooks.add ( 1 );
- except
- Application.MessageBox ( 'Versão do Ms-Excel' + 'Incompatível', 'Erro', MB_OK + MB_ICONEXCLAMATION );
- end;
- Dataset.DisableControls;
- Dataset.First;
- try
- for linha := 0 to Dataset.RecordCount - 1 do
- begin
- for coluna := 1 to Dataset.FieldCount do // eliminei a coluna 0 da relação do Excel
- begin
- valor := Dataset.Fields[ coluna - 1 ].AsString;
- excel.cells[ linha + 2, coluna ] := valor;
- end;
- Dataset.Next;
- end;
- for coluna := 1 to Dataset.FieldCount do // eliminei a coluna 0 da relação do Excel
- begin
- valor := Dataset.Fields[ coluna - 1 ].DisplayLabel;
- excel.cells[ 1, coluna ] := valor;
- end;
- // esta linha é para fazer com que o Excel dimencione as células adequadamente.
- excel.columns.AutoFit;
- excel.visible := true;
- except
- Application.MessageBox ( 'Aconteceu um erro desconhecido durante a conversão' + 'da tabela para o Ms-Excel', 'Erro', MB_OK + MB_ICONEXCLAMATION );
- end;
- Dataset.EnableControls;
- end;
- procedure TGeraCsv.NativeXls;
- begin
- ExportDatasettoXls( FDataset,FCaminho );
- end;
- procedure TGeraCsv.setFCaminho ( const Value: Ansistring );
- begin
- FCaminho := Value;
- end;
- procedure TGeraCsv.Start;
- var Th: TThread;
- begin
- GerarXlsx ( FDataset );
- end;
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement