问题: 倾家荡产求问数据导出Excel? ( 积分: 68 )
分类: 报表/统计图形
来自: ranyang, 时间: 2004-01-16 10:48:00, ID: 2414456
[?][
!]
我用的是datasource和ADOQuery连接数据库。mdb，我想做一个按钮，点击后能将查询到的数据导出到excel由用户自己编辑？！可以吗？
来自: ljlljl-79, 时间: 2004-01-16 10:55:00, ID: 2414480
你看一下此贴
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1696172
来自: 碧血剑, 时间: 2004-01-16 10:58:00, ID: 2414486
var
s: string;
begin
S := 'select * into [Excel 8.0;DATABASE=c:/temp/a.xls].[sheet1] from table'
ADOConnection.Execute(S);
end;
来自: weadvance, 时间: 2004-01-16 11:00:00, ID: 2414501
可以啊.
来自: archonwang, 时间: 2004-01-16 11:07:00, ID: 2414529
你有使用dbgrid吗？有的话参考这段源码
Question/Problem/Abstract:
I've been asked a quite a few times by the users if it would be possible to see the contents of a grid in excel because they want to do additional operations and not mess with the DB.
Answer:
The example dbgrid (DBGrid1) has a popup menu connected that allows to select the options "Send to Excel" and "Copy"
// NOTE: this method must include the COMObj, Excel97 units
// UPDATE: if you use Delphi 4 you can replace xlWBatWorkSheet with 1 (one)
//-----------------------------------------------------------
// if toExcel = false, export dbgrid contents to the Clipboard
// if toExcel = true, export dbgrid to Microsoft Excel
procedure ExportDBGrid(toExcel: Boolean);
var
bm: TBookmark;
col, row: Integer;
sline: String;
mem: TMemo;
ExcelApp: Variant;
begin
Screen.Cursor := crHourglass;
DBGrid1.DataSource.DataSet.DisableControls;
bm := DBGrid1.DataSource.DataSet.GetBookmark;
DBGrid1.DataSource.DataSet.First;
// create the Excel object
if toExcel then
begin
ExcelApp := CreateOleObject('Excel.Application');
ExcelApp.WorkBooks.Add(xlWBatWorkSheet);
ExcelApp.WorkBooks[1].WorkSheets[1].Name := 'Grid Data';
end;
// First we send the data to a memo
// works faster than doing it directly to Excel
mem := TMemo.Create(Self);
mem.Visible := false;
mem.Parent := MainForm;
mem.Clear;
sline := '';
// add the info for the column names
for col := 0 to DBGrid1.FieldCount-1 do
sline := sline + DBGrid1.Fields[col].DisplayLabel + #9;
mem.Lines.Add(sline);
// get the data into the memo
for row := 0 to DBGrid1.DataSource.DataSet.RecordCount-1 do
begin
sline := '';
for col := 0 to DBGrid1.FieldCount-1 do
sline := sline + DBGrid1.Fields[col].AsString + #9;
mem.Lines.Add(sline);
DBGrid1.DataSource.DataSet.Next;
end;
// we copy the data to the clipboard
mem.SelectAll;
mem.CopyToClipboard;
// if needed, send it to Excel
// if not, we already have it in the clipboard
if toExcel then
begin
ExcelApp.Workbooks[1].WorkSheets['Grid Data'].Paste;
ExcelApp.Visible := true;
end;
FreeAndNil(ExcelApp);
DBGrid1.DataSource.DataSet.GotoBookmark(bm);
DBGrid1.DataSource.DataSet.FreeBookmark(bm);
DBGrid1.DataSource.DataSet.EnableControls;
Screen.Cursor := crDefault;
end;
well those are my $2c.
please post if you have comments or it could be better written.
thnks..
如果你使用的是ole（不好意思，这个俺不熟，如果不明白需要另外找人帮忙）可以参考这段，不过呢，这段代码实现的是导出到xls文件。
Question/Problem/Abstract:
How can I export data into MS Excel workbook?
Answer:
Anyone who worked with OLE automation, know that OLE is very slowly.
Especially if you work using late binding (which have a lot of other
advantages which early binding haven't)
A reason of bad performance is the next:
every command (method or property) which you access (no matter in read or
write mode) will be interpretated (a-la script). I mean that this command
must be found in table of available methods/properties by string name and
only if found, a physical memory address for execution will be calculated.
So if your code contain a lot of access to methods/properties, your code
will be slow.
For example, you need transfer some data from Delphi application into
xls-spreadsheet.
You can solve a task in two different ways (now I describe only late binding
for OLE automation and don't describe another methods):
- to navigate thru own data and export every data in required cell
- to prepare a variant array with copied data and apply this array with data
into desired range of cells
I must say that second method will be faster than first because you'll call
less commands from OLE object and main code will be executed without OLE
automation.
Small sample: to export some StringGrid into xls-file.
var
xls, wb, Range: OLEVariant;
arrData: Variant;
begin
{create variant array where we'll copy our data}
arrData := VarArrayCreate([1, yourStringGrid.RowCount, 1,
yourStringGrid.ColCount], varVariant);
{fill array}
for i := 1 to yourStringGrid.RowCount do
for j := 1 to yourStringGrid.ColCount do
arrData[i, j] := yourStringGrid.Cells[j-1, i-1];
{initialize an instance of Excel}
xls := CreateOLEObject('Excel.Application');
{create workbook}
wb := xls.Workbooks.Add;
{retrieve a range where data must be placed}
Range := wb.WorkSheets[1].Range[wb.WorkSheets[1].Cells[1, 1],
wb.WorkSheets[1].Cells[yourStringGrid.RowCount, yourStringGrid.ColCount]];
{copy data from allocated variant array}
Range.Value := arrData;
{show Excel with our data}
xls.Visible := True;
end;
Of course, you must understand that such method is not good for large data
arrays because to allocate in memory large array is not easy task. You must
find some optimal size for data transfer (for example, to copy every 10
rows) and as result you'll receive an optimal code both for memory use and
performance.
Anyway more faster way to transfer data is not use OLE at all
You can use
my TSMExportToXLS component from SMExport suite
(http://www.scalabium.com/sme) for this task. There is implemented a direct
xls-file creation which doesn't require installed MS Excel at all..
With best regards, Mike Shkolnik
EMail: mshkolnik@scalabium.com
http://www.scalabium.com
来自: weadvance, 时间: 2004-01-16 11:35:00, ID: 2414620
begin
DBGrid1.DataSource:=DataSource1;
DataSource1.DataSet:=ADOQuery1;
ADOQuery1.Connection:=ADOConnection1;
ADOConnection1.ConnectionString:='Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+ExtractFilePath(Application.ExeName)+'book.xls;Extended Properties=Excel 8.0;Persist Security Info=False';
//--上面这个字符串指定用的Jet连接的Excel文件：book.xls。
ADOConnection1.LoginPrompt:=false;
ADOConnection1.Connected:=true;
with ADOQuery1 do
begin
Close;
SQL.Clear;
SQL.Add('select * from [sheet1$]');
Open; //－－此时DBGrid1中显示出Excel 的内容。导入到数据集成功。SQL中注意这个东东：sheet1$ 。
end;
end; // 注：D6＋Excel 2k 通过。
来自: xianguo, 时间: 2004-01-16 11:55:00, ID: 2414672
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1691966
来自: hhbbyy2000, 时间: 2004-01-16 12:03:00, ID: 2414697
简单方法：
首先 adoquery.open;要保证有数据。注意要调用 uses comobj
然后
var
x:OleVariant;
i:integer;
begin
x:=CreateOleObject('Excel.application');调用excel;
x.Workbooks.add;
x.Visible:=true;
x.cells(1,1):='标题';
x.cells(2,1):='列头';
i:=3;
wth adoquery do
begin
adoquery.first;
while not adoquery.eof do
begin
x.cells(i,1):=adoquery.fieldbyname('字段名').asstring;
.
.
// 以下不要说了吧
adoquery.next;
end;
end;
i:=i+1;
慢慢调试 ，绝对可以
来自: lushun8418, 时间: 2004-01-16 12:04:00, ID: 2414700
Unit excel;
interface
uses
Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls,ComObj;
//ComObj是操作OLE对象的函数集
type TForm1 =class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
eclApp,WorkBook:Variant;
//声明为OLE Automation 对象
xlsFileName:string;begin
xlsFileName:='ex.xls';
try
//创建OLE对象Excel Application与 WorkBook
eclApp:=CreateOleObject('Excel.Application');
WorkBook:=CreateOleobject('Excel.Sheet');
except
ShowMessage('您的机器里未安装Microsoft Excel。');
Exit;
end;
try
ShowMessage('下面演示:新建一个XLS文件,并写入数据,最后关闭它。');
workBook:=eclApp.workBooks.Add;
eclApp.Cells(1 , 1):='字符型';
eclApp.Cells(2 , 1):='Excel文件';
eclApp.Cells(1 , 2):='Money型';
eclApp.Cells(2 , 2):=10.01;
eclApp.Cells(1 , 3):='日期型';eclApp.Cells(2 , 3):=Date;
WorkBook.saveas(xlsFileName);
WorkBook.close;
ShowMessage('下面演示:打开刚创建的XLS文件,并修改其中的内容,然后,由用户决定是否保存。');
WorkBook:=eclApp.workBooks.Open(xlsFileName);
eclApp.Cells(2 , 1):='Excel文件类型';
if MessageDlg(xlsFileName+'文件已被修改,是否保存?',mtConfirmation, [mbYes, mbNo], 0) = mrYes then
WorkBook.save
else
workBook.Saved := True; //放弃修改
WorkBook.Close;
eclApp.Quit;
//退出Excel Application
//释放VARIANT变量
eclApp:=Unassigned;
except
ShowMessage('不能正确操作Excel文件。可能是该文件已被其他程序打开,或系统错误。');
WorkBook.close;
eclApp.Quit;
//释放VARIANT变量
eclApp:=Unassigned;
end;
end;
end.
来自: longbin, 时间: 2004-01-16 14:16:00, ID: 2415003
有一个非常简单的方法,只需一个控件,不用编码,而且有导出对话框,可以导出为多种文件格式,其中包括EXCEL控件名称是EMS QuickExportII,在www.51delphi.com上有下载
来自: fire-7, 时间: 2004-01-16 14:32:00, ID: 2415061
我想修改excel文件的默认文件名，该如何修改啊？
ExcelApplication1.Workbooks[1].Name:='我的文件名';
提示为' cannot assign to a read-only property '
来自: ranyang, 时间: 2004-01-16 17:18:00, ID: 2415475
To longbin,我怎么找不到那个控件亚！51delphi好像没有了！
另外感谢几位大虾！我正在努力学用！分就只有这么多了：（
来自: ing, 时间: 2004-01-16 17:27:00, ID: 2415494
著是一個把DataSet導入導excel的控件源代碼你自己新建立一個 控件復制進去就可以了
unit DataSetToExecl;
interface
uses
Windows, Messages, SysUtils,Controls,ComCtrls, Classes,DB,ComObj,Forms,ExtCtrls,StdCtrls,Graphics;
ResourceString
SErrorToConnectExecl ='錯誤連接Execl.確定本電腦是否裝有Execl';
SErrorToDataSetActive ='確定記錄集合是否在開啟狀態';
SErrorToEofDataSet ='空記的導出記錄集合';
SStartToExportData ='開始到導數劇.... 已導出%s/%s';
SCancel ='退出';
SConfirm ='是否要終止導出數據？';
SCaption ='提示';
type
TDataSetToExecl = class(Tcomponent)
private
ProgressForm: TForm;
Prompt: TLabel;
FDataSet: TDataSet;
Quit:Boolean;
FShowProgress: Boolean;
ProgressBar: TProgressBar;
ExcelApp:Variant;
FShowExeclApp: Boolean;
FExeclBookTitle: String;
FOnProgress: TNotifyEvent;
procedure SetDataSet(const Value: TDataSet);
procedure SetShowProgress(const Value: Boolean);
procedure SetShowExeclApp(const Value: Boolean);
procedure SetExeclBookTitle(const Value: String);
procedure ButtonClick(Sender: TObject);
{ Private declarations }
protected
{ Protected declarations }
Function ConnectExecl:boolean;
Function BuildProgress:boolean;
Procedure DataSetToExecl;
public
{ Public declarations }
Constructor Create(Aowner:TComponent); override;
Destructor Destroy(); override;
Procedure ExportDataSetToExecl;
published
Property DataSet:TDataSet read FDataSet write SetDataSet;
Property ShowProgress:Boolean read FShowProgress write SetShowProgress;
Property ShowExecLApp:Boolean read FShowExeclApp write SetShowExeclApp;
Property ExeclBookTitle:String read FExeclBookTitle write SetExeclBookTitle;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
{ Published declarations }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('gkControl', [TDataSetToExecl]);
end;
{ TDataSetToExecl }
function TDataSetToExecl.BuildProgress: boolean;
var
Panel : TPanel;
Button : TButton;
begin
if Assigned(ProgressForm) then exit; {Aready Create?}
ProgressForm := TForm.Create(Owner);
With ProgressForm do
begin
Font.Name := '宋体';
Font.Size := 10;
BorderStyle := bsNone;
Width := 280;
Height := 120;
BorderWidth := 1;
FormStyle:=fsStayOnTop;
Color := clBackground;
Position := poOwnerFormCenter;
end;
Panel := TPanel.Create(ProgressForm);
with Panel do { Create Panel }
begin
Parent := ProgressForm;
Align := alClient;
BevelInner := bvNone;
BevelOuter := bvRaised;
Caption := '';
end;
Prompt := TLabel.Create(Panel);
with Prompt do { Create Label }
begin
Parent := Panel;
Left := 20;
Top := 25;
Caption := SStartToExportData;
end;
ProgressBar := TProgressBar.Create(panel);
with ProgressBar do { Create ProgressBar }
begin
Step := 1;
Parent := Panel;
Smooth := true;
Left := Parent.Width div 2- Width div 2;
Top := 50;
Height := 18;
Width := 250;
end;
Button := TButton.Create(Panel);
with Button do { Create Cancel Button }
begin
Parent := Panel;
Left := Parent.Width div 2;
Top := 80;
Caption := SCancel;
OnClick := ButtonClick;
end;
ProgressForm.Show;
ProgressForm.Update;
end;
procedure TDataSetToExecl.ButtonClick(Sender: TObject);
begin
Quit := MessageBox(ProgressForm.Handle, pchar(SConfirm), pchar(SCaption),
MB_OKCANCEL + MB_ICONINFORMATION) = IDOK;
end;
function TDataSetToExecl.ConnectExecl: boolean;
begin
Try
ExcelApp := CreateOleObject('Excel.Application');
ExcelApp.Visible := FShowExeclApp;
if FExeclBookTitle<>'' then ExcelApp.Caption := FExeclBookTitle;
ExcelApp.WorkBooks.Add;
except
result := false;
raise exception.Create(SErrorToConnectExecl);
end;
result:=true;
end;
constructor TDataSetToExecl.Create(Aowner: TComponent);
begin
inherited;
FShowExeclApp:=true;
end;
procedure TDataSetToExecl.DataSetToExecl;
Var RBook:TBookMark;
I,J:integer;
OldBeforeScroll, OldAfterScroll: TDataSetNotifyEvent;
begin
try
Screen.Cursor := -11;
OldBeforeScroll := FDataSet.BeforeScroll; { Save Old Before Scroll Event handle }
OldAfterScroll := FDataSet.AfterScroll; { Save Old After Scroll Event Handle }
ExcelApp.DisplayAlerts := false;
ExcelApp.ScreenUpdating := false;
TForm(Owner).Enabled:=false;
FDataSet.DisableControls;
if ShowProgress then ProgressBar.Max := FDataSet.RecordCount;
RBook:=FDataSet.GetBookmark;
For I:=1 to FDataSet.FieldCount do {Export Filetile to Execel;}
ExcelApp.Cells[1,I].Value :=FDataSet.Fields[I-1].DisplayName;
J:=2;
While not FDataSet.Eof do
begin
For I:=0 to FDataSet.FieldCount-1 do
if FDataSet.Fields
is TBlobfield then
ExcelApp.cells[J,I+1].Value:='BlobField'
else
ExcelApp.cells[J,I+1].Value:=FDataSet.Fields.Value;
if Assigned(FOnProgress) then FOnProgress(Self);
if ShowProgress then { Update Progress UI }
begin
Prompt.Caption:=Format(SStartToExportData,[intToStr(J-2),intToStr(ProgressBar.Max)]);
Prompt.Update;
ProgressBar.StepIt;
Application.ProcessMessages;
if Quit then Break;
end;
FDataSet.Next;
Inc(J);
end;
if ShowProgress then FreeAndNil(ProgressForm); { Free Progress Form }
if RBook<>nil then FDataSet.GotoBookmark(RBook);
finally
ExcelApp.DisplayAlerts := True;
ExcelApp.ScreenUpdating := True;
ExcelApp.Visible := True;
FDataSet.BeforeScroll:=OldBeforeScroll;
FDataSet.AfterScroll:=OldAfterScroll;
FDataSet.FreeBookmark(RBook);
Screen.Cursor := 0;
FDataSet.EnableControls;
TForm(Owner).Enabled:=true;
end;
end;
destructor TDataSetToExecl.Destroy;
begin
inherited;
end;
procedure TDataSetToExecl.ExportDataSetToExecl;
begin
IF FdataSet=nil then Exception.Create(SErrorToDataSetActive);
If not FDataSet.Active then Raise Exception.Create(SErrorToDataSetActive);
if FDataSet.Eof then Raise Exception.Create(SErrorToEofDataSet);
if not ConnectExecl then Raise Exception.Create(SErrorToConnectExecl);
if FShowProgress then BuildProgress ;
DataSetToExecl;
end;
procedure TDataSetToExecl.SetDataSet(const Value: TDataSet);
begin
if fDataSet<>Value then
FDataSet := Value;
end;
procedure TDataSetToExecl.SetExeclBookTitle(const Value: String);
begin
if FExeclBookTitle <> Value then
FExeclBookTitle := Value;
end;
procedure TDataSetToExecl.SetShowExeclApp(const Value: Boolean);
begin
if FShowExeclApp<>value then
FShowExeclApp := Value;
end;
procedure TDataSetToExecl.SetShowProgress(const Value: Boolean);
begin
if FShowProgress<>value then
FShowProgress := Value;
end;
end.
来自: renyi, 时间: 2004-01-16 21:15:00, ID: 2415730
用Ehlib控件，它支持这个功能，非常简单。
来自: canghesoft, 时间: 2004-01-16 21:23:00, ID: 2415737
一、先书写这个文件XLSfile.pas
unit XLSfile;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
const
{BOF}
CBOF = $0009;
BIT_BIFF5 = $0800;
BIT_BIFF4 = $0400;
BIT_BIFF3 = $0200;
BOF_BIFF5 = CBOF or BIT_BIFF5;
BOF_BIFF4 = CBOF or BIT_BIFF4;
BOF_BIFF3 = CBOF or BIT_BIFF3;
{EOF}
BIFF_EOF = $000a;
{Document types}
DOCTYPE_XLS = $0010;
DOCTYPE_XLC = $0020;
DOCTYPE_XLM = $0040;
DOCTYPE_XLW = $0100;
{Dimensions}
DIMENSIONS = $0000;
DIMENSIONS_BIFF4 = DIMENSIONS or BIT_BIFF3;
DIMENSIONS_BIFF3 = DIMENSIONS or BIT_BIFF3;
type
EReadError = class(Exception);
EopCodeError = class(Exception);
EOverUnderError = class(Exception);
TModeOpen = (moWrite); //,moRead); //read not implemented yet
TAtributCell = (acHidden,acLocked,acShaded,acBottomBorder,acTopBorder,
acRightBorder,acLeftBorder,acLeft,acCenter,acRight,acFill);
TSetOfAtribut = set of TatributCell;
TMyFiler = class
public
Stream:TStream; //stream yang akan diisi/dibaca
end;
TMyReader = class(TMyFiler)
public
function readStr:string;
function readDouble:double;
function readInt:integer;
function readByte:byte;
function readWord:word;
end;
TMyWriter = class(TMyFiler)
public
procedure WriteSingleStr(s:string);
//tidak ada informasi length di depan str,
//digunakan untuk cell string di Excel
procedure WriteStr(s:string);
{req: s shouldn't exceed 64KB
}
procedure WriteByte(b:byte);
procedure WriteDouble(d:double);
procedure WriteInt(i:integer);
procedure WriteWord(w:word);
end;
TMyPersistent = class
public
opCode:word; //invarian: opcode<>nil, opcode<>opcodeEOF dan dalam satu aplikasi tidak boleh ada class yang memiliki opcode sama
procedure Write(W:TMyWriter);virtual;abstract;
{req: opcode sudah diisikan}
procedure Read(R:TMyReader);virtual;abstract;
{req: opcode sudah diisikan}
end;
TDispatcher = class
private
StrList:TStringList;
Reader:TMyReader;
Writer:TMyWriter;
protected
FStream:TStream; //stream yang menjadi target
procedure SetStream(vStream:TStream);
public
SLError:TStringList;
OpcodeEOF:word; //opcode yg menandakan EOF
procedure Clear;
procedure RegisterObj(MyPers:TMyPersistent);
{req: MyPersistent.opCode<>0
ens: MyPersistent terdaftar}
procedure Write;
{ens: semua data obj yang mendaftar masuk dalam stream}
procedure Read;
{ens: semua obj yang mendaftar terisi}
constructor create;
destructor destroy;override;
property Stream : TStream read FStream write SetStream;
end;
TData = class(TMyPersistent)
end;
TBOF = class (TData) //record awal di file
procedure read(R:TMyReader);override;
{req: opcode sudah diisi}
procedure write(W:TMyWriter);override;
{req: opcode sudah diisi}
constructor create;
end;
TDimension = class(TData) //record akhir
MinSaveRecs,MaxSaveRecs,MinSaveCols,MaxSaveCols:word;
procedure read(R:TMyReader);override;
{req: opcode sudah diisi}
procedure write(W:TMyWriter);override;
{req: opcode sudah diisi}
constructor create;
end;
TCellClass = class of TCell;
TCell = class(TData)
protected
FAtribut:array [0..2] of byte;
procedure SetAtribut(value:TSetOfAtribut);
{ens: FAtribut diatur sesuai dengan nilai value}
public
Col,Row:word; //dari 1
procedure read(R:TMyReader);override;
procedure write(W:TMyWriter);override;
property Atribut : TSetOfAtribut write SetAtribut; //baru bisa nulis
constructor create;virtual;abstract;
end;
TBlankCell = class(TCell)
procedure read(R:TMyReader);override;
procedure write(W:TMyWriter);override;
{req: col, row dan atribut sudah ditulis}
constructor create;override;
end;
TDoubleCell = class(TCell)
Value:double;
procedure read(R:TMyReader);override;
procedure write(W:TMyWriter);override;
{req: col, row dan atribut sudah ditulis}
constructor create;override;
end;
TWordCell = class(TCell)
Value:word;
procedure read(R:TMyReader);override;
procedure write(W:TMyWriter);override;
{req: col, row dan atribut sudah ditulis}
constructor create;override;
end;
TStrCell = class(TCell)
Value:string;
procedure read(R:TMyReader);override;
procedure write(W:TMyWriter);override;
{req: col, row dan atribut sudah ditulis}
constructor create;override;
end;
TXLSfile = class(TComponent)
private
FFileName:string;
ModeOpen:TModeOpen;
Dispatcher:TDispatcher;
BOF:TBOF;
Dimension:TDimension;
function AddCell(vCol,vRow:word;vAtribut:TSetOfAtribut;CellRef:TCellClass):TCell;
procedure AddData(D:TData);
protected
{ Protected declarations }
public
{ Public declarations }
procedure AddWordCell(vCol,vRow:word;vAtribut:TSetOfAtribut;aValue:word);
procedure AddDoubleCell(vCol,vRow:word;vAtribut:TSetOfAtribut;aValue:double);
procedure AddStrCell(vCol,vRow:word;vAtribut:TSetOfAtribut;aValue:String);
procedure write;
procedure clear;
constructor create(AOwner:TComponent);override;
destructor destroy;override;
published
{ Published declarations }
property FileName :string read FFileName write FFileName;
end;
implementation
function TMyReader.readByte:byte;
begin
Stream.Read(result,1);
end;
function TMyReader.readWord:word;
begin
Stream.Read(result,2); //panjang string
end;
function TMyReader.readStr:string;
var
Panjang:Word;
tempStr:string;
begin
Stream.Read(Panjang,2); //panjang string
SetLength(tempStr,panjang);
Stream.Read(tempStr[1],panjang);
result:=tempStr;
end;
function TMyReader.readDouble:double;
begin
Stream.Read(result,8);
end;
function TMyReader.readInt:integer;
begin
Stream.Read(result,4);
end;
procedure TMyWriter.WriteByte(b:byte);
begin
Stream.write(b,1);
end;
procedure TMyWriter.WriteWord(w:word);
begin
Stream.write(w,2);
end;
procedure TMyWriter.WriteSingleStr(s:string);
begin
Stream.write(s[1],length(s));
end;
procedure TMyWriter.WriteStr(s:string);
{req: s shouldn't exceed 64KB
}
var
panjang:integer;
begin
panjang:=length(s);
WriteWord(panjang);
Stream.write(s[1],panjang);
end;
procedure TMyWriter.WriteDouble(d:double);
begin
Stream.write(d,8); //asumsi double adalah 8 bytes
end;
procedure TMyWriter.WriteInt(i:integer);
begin
Stream.write(i,4);
end;
procedure TDispatcher.Clear;
var
i:integer;
begin
for i:=0 to StrList.count-1 do
begin
TMyPersistent(StrList.Objects).Free;
end;
StrList.Clear;
SLError.Clear;
end;
procedure TDispatcher.SetStream(vStream:TStream);
begin
FStream:=vStream;
Reader.Stream:=Fstream;
Writer.stream:=Fstream;
end;
constructor TDispatcher.create;
begin
OpCodeEOF:=999;
StrList:=TStringlist.create;
Reader:=TMyReader.create;
Writer:=TMyWriter.create;
SLError:=TStringList.create;
end;
destructor TDispatcher.destroy;
begin
Clear;
StrList.free;
Reader.free;
Writer.free;
SLError.free;
inherited;
end;
procedure TDispatcher.RegisterObj(MyPers:TMyPersistent);
{req: MyPersistent.opCode<>0
ens: MyPersistent terdaftar}
begin
StrList.AddObject(IntToStr(MyPers.opCode),MyPers);
end;
procedure TDispatcher.Write;
{ens: semua data obj yang mendaftar masuk dalam stream}
var
i:integer;
pos,length:longint;
begin
//index stream, mulai dari 0!
for i:=0 to StrList.Count-1 do
begin
Writer.WriteWord(TMyPersistent(StrList.objects).Opcode); //opcode
Writer.WriteWord(0); //untuk tempat length record, nanti diisi lagi
pos:=Stream.Position;
TMyPersistent(StrList.Objects).Write(Writer);
//length-nya jangan lupa
length:=Stream.Position-pos;
Stream.Seek(-(length+2),soFromCurrent); //balikin ke posisi tempat length
Writer.WriteWord(length);
Stream.Seek(length,soFromCurrent); //siap menulis lagi
end;
//penutup
Writer.WriteWord(opCodeEOF);
Writer.WriteWord(0); //panjangnya 0
end;
procedure TDispatcher.Read;
{ req: StrList terurut
ens: semua obj yang mendaftar terisi}
var
idx:integer;
opCode:word;
panjang,pos:longint;
stop:boolean;
begin
stop:=false;
while not(stop) do
begin
opCode:=Reader.ReadWord;
panjang:=Reader.ReadWord;
if opCode = opCodeEOF then
stop:=true
else
begin
pos:=Stream.Position;
idx:=StrList.IndexOf(IntToStr(opcode));
if idx <> -1 then
TMyPersistent(StrList.Objects[idx]).Read(Reader)
else
begin //opcode nggak dikenali
SLError.Add(format('Unknown Opcode %d ',[opCode]));
Stream.Seek(panjang,soFromCurrent); //repair
end;
//cek apakah kelewatan/kurang ngebacanya
if Stream.Position <> pos+panjang then
begin
begin
if Stream.Position<pos+panjang then
begin
SLError.Add(Format('Opcode %d underrun %d bytes',[opcode,(pos+panjang)-Stream.Position]));
Stream.Seek(Stream.Position - (pos+panjang),soFromCurrent);//repair
end
else
begin
SLError.Add(Format('Opcode %d overrun %d bytes',[opcode,Stream.Position-(pos+panjang)]));
Stream.Seek((pos+panjang)-Stream.Position,soFromCurrent); //repair
end;
end;
end;
end; //opcode EOF
end; //end while
if SLerror.count>0 then
begin
raise EReadError.Create
('File format error or file corrupt . Choose File -> Save as to save this file with new format');
end;
end;
constructor TXLSFile.create(AOwner:TComponent);
begin
inherited create(AOwner);
ModeOpen:=moWrite;
Dispatcher:=TDispatcher.create;
Dispatcher.opcodeEOF:=BIFF_EOF;
clear;
end;
destructor TXLSFile.destroy;
begin
Dispatcher.free;
inherited;
end;
function TXLSFile.AddCell(vCol,vRow:word;vAtribut:TSetOfAtribut;CellRef:TCellClass):TCell;
//vCol dan Vrow mulai dari 0
//ens: XLSfile yg buat, XLSFile yang bertanggung jawab
var
C:TCell;
begin
C:=CellRef.create;
with C do
begin
Col:=vCol-1;
Row:=vRow-1; //yw 23 agt
Atribut:=vAtribut;
end;
AddData(C);
Result:=C;
end;
procedure TXLSFile.AddWordCell(vCol,vRow:word;vAtribut:TSetOfAtribut;aValue:word);
begin
with TWordCell(AddCell(vCol,vRow,vAtribut,TWordCell)) do
value:=aValue;
end;
procedure TXLSFile.AddDoubleCell(vCol,vRow:word;vAtribut:TSetOfAtribut;aValue:double);
begin
with TDoubleCell(AddCell(vCol,vRow,vAtribut,TDoubleCell)) do
value:=aValue;
end;
procedure TXLSFile.AddStrCell(vCol,vRow:word;vAtribut:TSetOfAtribut;aValue:String);
begin
with TStrCell(AddCell(vCol,vRow,vAtribut,TStrCell)) do
value:=aValue;
end;
procedure TXLSFile.AddData(D:TData);
//req: BOF dan dimension telah ditambahkan lebih dulu
begin
Dispatcher.RegisterObj(D);
end;
procedure TXLSFile.write;
{req: ListDAta telah diisi}
var
FileStream:TFIleStream;
begin
FileStream:=TFileStream.Create(FFileName,fmCreate);
Dispatcher.Stream:=FileStream;
Dispatcher.Write;
FileStream.Free;
end;
procedure TXLSFile.clear;
{req: - objek data yang dibuat secara manual (lewat c:=TWordCell.create dst..) sudah di-free
- BOF<>nil, Dimension<>nil }
begin
Dispatcher.Clear;
BOF:=TBOF.create;
Dimension:=TDimension.create;
Dispatcher.RegisterObj(BOF); //harus pertama
Dispatcher.RegisterObj(Dimension); //harus kedua
end;
//TBOF ********************************************************************
constructor TBOF.create;
begin
opCOde:=BOF_BIFF5;
end;
procedure TBOF.read(R:TMyReader);
begin
end;
procedure TBOF.write(W:TMyWriter);
{req: opcode sudah diisikan}
begin
with W do
begin
writeWord(0); //versi
writeWord(DOCTYPE_XLS);
writeWord(0);
end;
end;
//TDimension ****************************************************************
procedure TDimension.read(R:TMyReader);
{req: opcode sudah diisi}
begin
end;
procedure TDimension.write(W:TMyWriter);
{req: opcode sudah diisi}
begin
with w do
begin
WriteWord(MinSaveRecs);
WriteWord(MaxSaveRecs);
WriteWord(MinSaveCols);
WriteWord(MaxSaveCols);
end;
end;
constructor TDimension.create;
begin
opCode:=DIMENSIONS;
MinSaveRecs := 0; MaxSaveRecs := 1000;
MinSaveCols := 0; MaxSaveCols := 100;
end;
//TCell ******************************************************************
procedure TCell.SetAtribut(value:TSetOfAtribut);
{ens: FAtribut diatur sesuai dengan nilai value}
var
i:integer;
begin
//reset
for i:=0 to High(FAtribut) do
FAtribut:=0;
{Byte Offset Bit Description Contents
0 7 Cell is not hidden 0b
Cell is hidden 1b
6 Cell is not locked 0b
Cell is locked 1b
5-0 Reserved, must be 0 000000b
1 7-6 Font number (4 possible)
5-0 Cell format code
2 7 Cell is not shaded 0b
Cell is shaded 1b
6 Cell has no bottom border 0b
Cell has a bottom border 1b
5 Cell has no top border 0b
Cell has a top border 1b
4 Cell has no right border 0b
Cell has a right border 1b
3 Cell has no left border 0b
Cell has a left border 1b
2-0 Cell alignment code
general 000b
left 001b
center 010b
right 011b
fill 100b
Multiplan default align. 111b
}
// bit sequence 76543210
if acHidden in value then //byte 0 bit 7:
FAtribut[0] := FAtribut[0] + 128;
if acLocked in value then //byte 0 bit 6:
FAtribut[0] := FAtribut[0] + 64 ;
if acShaded in value then //byte 2 bit 7:
FAtribut[2] := FAtribut[2] + 128;
if acBottomBorder in value then //byte 2 bit 6
FAtribut[2] := FAtribut[2] + 64 ;
if acTopBorder in value then //byte 2 bit 5
FAtribut[2] := FAtribut[2] + 32;
if acRightBorder in value then //byte 2 bit 4
FAtribut[2] := FAtribut[2] + 16;
if acLeftBorder in value then //byte 2 bit 3
FAtribut[2] := FAtribut[2] + 8;
if acLeft in value then //byte 2 bit 1
FAtribut[2] := FAtribut[2] + 1
else
if acCenter in value then //byte 2 bit 1
FAtribut[2] := FAtribut[2] + 2
else if acRight in value then //byte 2, bit 0 dan bit 1
FAtribut[2] := FAtribut[2] + 3;
if acFill in value then //byte 2, bit 0
FAtribut[2] := FAtribut[2] + 4;
end;
procedure TCell.read(R:TMyReader);
begin
end;
procedure TCell.write(W:TMyWriter);
{req: opcode sudah ditulis}
var
i:integer;
begin
with w do
begin
WriteWord(Row);
WriteWord(Col);
for i:=0 to 2 do
begin
writeByte(FAtribut);
end;
end;
end;
//TBlankCell **************************************************************
procedure TBlankCell.read(R:TMyReader);
begin
end;
procedure TBlankCell.write(W:TMyWriter);
{req: col, row dan atribut sudah ditulis}
begin
end;
constructor TBlankCell.create;
begin
opCode:=1;
end;
//TWordCell **************************************************************
procedure TWordCell.read(R:TMyReader);
begin
end;
procedure TWordCell.write(W:TMyWriter);
{req: col, row dan atribut sudah ditulis}
begin
inherited write(W);
w.WriteWord(value);
end;
constructor TWordCell.create;
begin
opCode:=2;
end;
//TDoubleCell **************************************************************
procedure TDoubleCell.read(R:TMyReader);
begin
end;
procedure TDoubleCell.write(W:TMyWriter);
{req: col, row dan atribut sudah ditulis}
begin
inherited write(W);
w.writeDouble(value);
end;
constructor TDoubleCell.create;
begin
opCode:=3;
end;
//TStrCell ***************************************************************
procedure TStrCell.read(R:TMyReader);
begin
inherited read(R);
end;
procedure TStrCell.write(W:TMyWriter);
{req: col, row dan atribut sudah ditulis}
begin
inherited Write(W);
w.WriteByte(length(value));
w.WriteSIngleStr(value);
end;
constructor TStrCell.create;
begin
opCode:=4;
end;
end.
二、导出按钮内容（例子）：
var i:integer;filename:string;XLSfile1:TXLSfile;
begin
Button1Click(self);
filename:=systemdata.ProgramPath+'tmp.XLS';
XLSfile1:=TXLSfile.create(self);
XLSfile1.clear;
XLSfile1.FileName:=filename;
for i:=1 to tsgrid1.cols do
XLSfile1.AddStrCell(i,1,[],tsgrid1.Col.Heading);
Datamodule1.ADOQ1.First;
while not Datamodule1.ADOQ1.eof do
begin
for i:=1 to tsgrid1.cols do
XLSfile1.AddStrCell(i,Datamodule1.ADOQ1.recno+1,[],Datamodule1.ADOQ1.fieldbyname(tsgrid1.Col.heading).DisplayText);
Datamodule1.ADOQ1.next;
end;
XLSfile1.write;
XLSfile1.free;
shellexecute(handle,pchar('open'),pchar('EXCEL.EXE'),pchar(FileName),nil,SW_SHOWNORMAL);
end;
这样你可以决定导出什么内容和什么导出！
来自: sql1981, 时间: 2004-01-16 21:56:00, ID: 2415769
dbgrideh
来自: ranyang, 时间: 2004-01-17 9:37:00, ID: 2416173
To 碧血剑
您的办法我不太会呀！
来自: hzjone, 时间: 2004-01-17 11:08:00, ID: 2416390
这个我在DELPHI6运行通过的。绝对可以用的。
procedure tfrmprint2.saveAsExcel;
var
fieldNum: integer;
i,j : integer;
exls,sheet: variant;
begin
try
exls:=createoleobject('Excel.application');
sheet:=createoleobject('excel.sheet');
except
application.MessageBox('请先安装MICROSOFT EXCEL！','提示',mb_ok+mb_iconinformation);
exit;
end;
sheet:=exls.workBooks.Add;
with query2 do
begin
DisableControls;
fieldNum := dbgrid1.fieldCount;
for i:=1 to fieldNum do
begin
exls.Cells[1,i].value:=Fields[i-1].FieldName;
end;
first;
i:=2;
while not eof do
begin
for j:=1 to fieldNum do
begin
exls.Cells[i,j]:=fields[j-1].AsString;
end;
next;
i:=i+1;
end;
EnableControls;
exls.visible:=true;
end;
end;
来自: ranyang, 时间: 2004-01-17 14:30:00, ID: 2416763
谢谢各位大虾@
]
来自: longbin, 时间: 2004-01-17 17:11:00, ID: 2417097
给个邮箱吧,我发给你
来自: blyb, 时间: 2004-01-17 17:15:00, ID: 2417105
可以结贴了。
来自: ranyang, 时间: 2004-01-17 17:54:00, ID: 2417150
好！flywolf@jxfw.com谢谢各位大哥！
来自: ranyang, 时间: 2004-01-17 18:07:00, ID: 2417162
只有这么多了！以后等我有了！再给各位吧！谢谢！！多人接受答案了。
得分大富翁: archonwang-7,canghesoft-7,hhbbyy2000-7,hzjone-7,ing-6,ljlljl-79-3,longbin-7,lushun8418-7,weadvance-7,xianguo-3,碧血剑-7,