MyExcel.WorkBooks[1].WorkSheets[1].Columns[x].ColumnWidth := dbgrid.Fields[x-1].DisplayWidth; end; inc(y); while not dbgrid.DataSource.DataSet.eof do begin for x:=1 to dbgrid.FieldCount do begin MyExcel.WorkBooks[1].WorkSheets[1].Cells[y,x] := dbgrid.Fields[x-1].AsString; end; inc(y); dbgrid.DataSource.DataSet.next; end; end; procedure TForm1.Button1Click(Sender: TObject); begin DBGrid2Excel(dbgrid1,edit1.text); end; procedure TForm1.LabelDelphiKTopClick(Sender: TObject); begin ShellExecute(application.handle,pchar('OPEN'),pchar('http://www.chetel.com.cn'),nil,nil,0); end;
----------------------------------------------
虽千万人吾往矣!
procedure SetCellAtribut(value:TSetOfAtribut;var FAtribut:array of byte); procedure DataSetToXLS(ds:TDataSet;fname:String);
implementation
procedure DataSetToXLS(ds:TDataSet;fname:String); var c,r:Integer; xls:TXLSWriter; begin xls:=TXLSWriter.create(fname); if ds.FieldCount > xls.maxcols then xls.maxcols:=ds.fieldcount+1; try xls.writeBOF; xls.WriteDimension; for c:=0 to ds.FieldCount-1 do xls.Cellstr(0,c,ds.Fields[c].FieldName); r:=1; ds.first; while not ds.eof do begin for c:=0 to ds.FieldCount-1 do xls.WriteField(r,c,ds.Fields[c]); inc(r); ds.next; end; if r > xls.maxrows then begin xls.fstream.Seek(10,soFromBeginning); xls.WriteDimension; end; xls.writeEOF; finally xls.free; end; end;
{ TXLSWriter }
constructor TXLSWriter.create(vFileName:string); begin inherited create; if FileExists(vFilename) then fStream:=TFileStream.Create(vFilename,fmOpenWrite) else fStream:=TFileStream.Create(vFilename,fmCreate);
maxCols:=100; maxRows:=1000; end;
destructor TXLSWriter.destroy; begin if fStream <> nil then fStream.free; inherited; end;
procedure TXLSWriter.WriteBOF; begin Writeword(BOF_BIFF5); Writeword(6); //count of bytes Writeword(0); Writeword(DOCTYPE_XLS); Writeword(0); end;
procedure TXLSWriter.WriteDimension; begin Writeword(DIMENSIONS); // dimension OP Code Writeword(8); //count of bytes Writeword(0); // min cols Writeword(maxRows); // max rows Writeword(0); // min rowss Writeword(maxcols); // max cols end;
procedure TXLSWriter.CellDouble(vCol, vRow: word; aValue: double; vAtribut: TSetOfAtribut); var FAtribut:array [0..2] of byte; begin Writeword(3); // opcode for double Writeword(15); // count of byte Writeword(vCol); Writeword(vRow); SetCellAtribut(vAtribut,fAtribut); fStream.Write(fAtribut,3); fStream.Write(aValue,8); end;
procedure TXLSWriter.CellWord(vCol,vRow:word;aValue:word;vAtribut:TSetOfAtribut=[]); var FAtribut:array [0..2] of byte; begin Writeword(2); // opcode for word Writeword(9); // count of byte Writeword(vCol); Writeword(vRow); SetCellAtribut(vAtribut,fAtribut); fStream.Write(fAtribut,3); Writeword(aValue); end;
procedure TXLSWriter.CellStr(vCol, vRow: word; aValue: String; vAtribut: TSetOfAtribut); var FAtribut:array [0..2] of byte; slen:byte; begin Writeword(4); // opcode for string slen:=length(avalue); Writeword(slen+8); // count of byte Writeword(vCol); Writeword(vRow); SetCellAtribut(vAtribut,fAtribut); fStream.Write(fAtribut,3); fStream.Write(slen,1); fStream.Write(aValue[1],slen); end;
procedure SetCellAtribut(value:TSetOfAtribut;var FAtribut:array of byte); var i:integer; begin //reset for i:=0 to High(FAtribut) do FAtribut[i]:=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 TXLSWriter.WriteWord(w: word); begin fstream.Write(w,2); end;
procedure TXLSWriter.WriteEOF; begin Writeword(BIFF_EOF); Writeword(0); end;
procedure TXLSWriter.WriteField(vCol, vRow: word; Field: TField); var FAtribut:array [0..2] of byte; begin case field.DataType of ftString,ftWideString,ftBoolean,ftDate,ftDateTime,ftTime: Cellstr(vcol,vrow,field.asstring); ftSmallint,ftInteger,ftWord: CellWord(vcol,vRow,field.AsInteger); ftFloat, ftBCD: CellDouble(vcol,vrow,field.AsFloat); end; end;
//===================================================================== unit Unit1;