DBGRID数据导如到指定的excle文件中 ( 积分: 100 )

[]我想把query检索到的数据导入到指定的excel文件中,有标题行,且有一个字段的值为1-2是文本型.可在excel里总是已日期型显示

procedure DeriveToExcel(Title: String; DBGrid: TDBGrid; Total: Boolean);
var
ExcelApp, WorkBook: Variant;
i, j: Integer;
Row, Col: Integer;
FieldName: string;
DataSet: TDataSet;
S: String;
begin
// ?据?送到 Excel
try
ExcelApp := CreateOleObject('Excel.Application');
WorkBook := CreateOleObject('Excel.Sheet');
except
Application.MessageBox('你的机器里未安?Microsoft Excel. ', '', 32);
Exit;
end;

Application.ProcessMessages;
WorkBook := ExcelApp.WorkBooks.Add;
Col := 1;
ExcelApp.Cells(1, Col) := Title;
Row := 2;
DataSet := DBGrid.DataSource.DataSet;
for I := 0 to DBGrid.Columns.Count - 1 do
begin
if DBGrid.Columns.Visible then
begin
FieldName := DBGrid.Columns.Title.Caption;
ExcelApp.Cells(Row, Col) := FieldName;
Col := Col + 1;
end;
end;

Row := Row + 1;

DataSet.First;
while not DataSet.Eof do
begin
Col := 1;
for J := 0 to DBGrid.Columns.Count - 1 do
begin
FieldName := DBGrid.Columns[J].FieldName;
ExcelApp.Cells(Row, Col) :=DataSet.FieldByName(FieldName).AsString;
Col := Col + 1;
end;
Row := Row + 1;
DataSet.Next;
end;

if Total then
begin
Col := 1;
for J := 0 to DBGrid.Columns.Count - 1 do
begin
S := Char(64 + ((J+1) mod 26));
if (J+1) > 26 then
begin
S := Char(65+(((J+1)-26) div 26)) + S;
end;
if J = 0 then
begin
ExcelApp.Cells(Row, Col) := '合?';
end
else if DBGrid.Columns[J].Field.DataType in [ftInteger, ftSmallint, ftFloat, ftBCD] then
begin
FieldName := DBGrid.Columns[J].FieldName;
ExcelApp.Cells(Row, Col) := '=SUM('+S+'4:'+S+IntToStr(Row-1)+')';
end;
Col := Col + 1;
end;
end;
ExcelApp.Visible := false;
if Form1.SaveDialog1.Execute then
begin
WorkBook.SaveAs(Form1.SaveDialog1.FileName);
WorkBook.Close;
ExcelApp.Quit;
ExcelApp := Unassigned;
end;
// WorkBook.SaveAs(SaveDialog1.FileName);
// WorkBook.Close;
// ExcelApp.Quit;
// ExcelApp := Unassigned;
end;

unit DBGrid2Excel;

interface

uses
Windows, Variants, Classes, SysUtils, StdCtrls,Forms, ExtCtrls,DB, DBGrids, ComObj;

type
TUpAniInfoProc = procedure (const sInfo: string) of object;

function DBGridToExcel(dgrSource: TDBGrid;
UpAniInfo: TUpAniInfoProc = nil): Integer;
function DataSetToExcel(DataSet: TDataSet;
UpAniInfo: TUpAniInfoProc = nil): Integer;
implementation

uses Unit1;


const
MAX_SHEET_ROWS = 65536-1; //Excel每Sheet最大行数
MAX_VAR_ONCE = 1000; //一次导出的条数

function DBGridToExcel(dgrSource: TDBGrid; UpAniInfo: TUpAniInfoProc): Integer;
var //从DBGrid导出到Excel(2005.8.23改进至可以导入几乎无限的数据)
MyExcel, varCells: Variant;
MySheet, MyCells, Cell1, Cell2, Range: OleVariant;
iRow, iCol, iRealCol, iSheetIdx, iVarCount, iCurRow, iFieldCount: integer;
CurPos: TBookmark;
DataSet: TDataSet;
sFieldName: string;
begin //返回导出记录条数
DataSet := dgrSource.DataSource.DataSet;

DataSet.DisableControls;
CurPos := DataSet.GetBookmark;
DataSet.First;

MyExcel := CreateOleObject('Excel.Application');
MyExcel.WorkBooks.Add;
MyExcel.Visible := False;

if DataSet.RecordCount <= MAX_VAR_ONCE then
iVarCount := DataSet.RecordCount
else
iVarCount := MAX_VAR_ONCE;

iFieldCount := dgrSource.Columns.Count; //对DBGrid，只导出显示的列
for iCol:=0 to dgrSource.Columns.Count-1 do
if not dgrSource.Columns[iCol].Visible then //可能有不显示的列 2005.9.10
Dec(iFieldCount);
varCells := VarArrayCreate([1,
iVarCount,
1,
iFieldCount], varVariant);
iSheetIdx := 1;
iRow := 0;
Result := 0;
while not DataSet.Eof do
begin
if (iRow = 0) or (iRow > MAX_SHEET_ROWS + 1) then
begin //新增一个Sheet
if iSheetIdx <= MyExcel.WorkBooks[1].WorkSheets.Count then
MySheet := MyExcel.WorkBooks[1].WorkSheets[iSheetIdx]
else
MySheet := MyExcel.WorkBooks[1].WorkSheets.Add(NULL, MySheet);//加在后面
MyCells := MySheet.Cells;
Inc(iSheetIdx);
iRow := 1;

iRealCol := 0;
for iCol := 1 to iFieldCount do
begin
MySheet.Cells[1, iCol].Font.Bold := True;
{MySheet.Select;
MySheet.Cells[iRow,iCol].Select;
MyExcel.Selection.Font.Bold := true;}//这种方法也可(Sheet.Select不可少)
while not dgrSource.Columns[iRealCol].Visible do
Inc(iRealCol); //跳过不可见的列 2005.9.10
MySheet.Cells[1, iCol] := dgrSource.Columns[iRealCol].Title.Caption;
MySheet.Columns[iCol].ColumnWidth := //2005.9.9 以下方法似乎算得还行
Integer(Round(dgrSource.Columns[iRealCol].Width * 2
/ abs(dgrSource.Font.Height)));
sFieldName := dgrSource.Columns[iRealCol].FieldName;
if (DataSet.FieldByName(sFieldName).DataType = ftString)
or (DataSet.FieldByName(sFieldName).DataType = ftWideString) then
begin //对于“字符串”型数据则设Excel单元格为“文本”型
MySheet.Columns[iCol].NumberFormatLocal := '@';
end;
Inc(iRealCol);
end;
Inc(iRow);
end;
iCurRow := 1;
while not DataSet.Eof do
begin
iRealCol := 0;
for iCol := 1 to iFieldCount do
begin
while not dgrSource.Columns[iRealCol].Visible do
Inc(iRealCol); //跳过不可见的列 2005.9.10
sFieldName := dgrSource.Columns[iRealCol].FieldName;
varCells[iCurRow, iCol] := DataSet.FieldByName(sFieldName).AsString;
Inc(iRealCol);
end;
Inc(iRow);
Inc(iCurRow);
Inc(Result);
DataSet.Next;
if (iCurRow > iVarCount) or (iRow > MAX_SHEET_ROWS + 1) then
begin
if Assigned(UpAniInfo) then
UpAniInfo(Format('(已导出%d条)', [Result])); //显示已导出条数
Application.ProcessMessages;
Break;
end;
end;
Cell1 := MyCells.Item[iRow - iCurRow + 1, 1];
Cell2 := MyCells.Item[iRow - 1,
iFieldCount];
Range := MySheet.Range[Cell1 ,Cell2];
Range.Value := varCells;
if (iRow > MAX_SHEET_ROWS + 1) then //一个Sheet导出结束
begin
MySheet.Select;
MySheet.Cells[1, 1].Select; //使得每一Sheet均定位在第一格
end;
Cell1 := Unassigned;
Cell2 := Unassigned;
Range := Unassigned;

end;

MyCells := Unassigned;
varCells := Unassigned;
MyExcel.WorkBooks[1].WorkSheets[1].Select; //必须先选Sheet 2005.8.23
MyExcel.WorkBooks[1].WorkSheets[1].Cells[1,1].Select;
MyExcel.Visible := True;
MyExcel.WorkBooks[1].Saved := True;
MyExcel := Unassigned;
if CurPos <> nil then
begin
DataSet.GotoBookmark(CurPos);
DataSet.FreeBookmark(CurPos);
end;
DataSet.EnableControls;
end;

function DataSetToExcel(DataSet: TDataSet; UpAniInfo: TUpAniInfoProc): Integer;
var //从DataSet导出到Excel(2005.8.23改进至可以导入几乎无限的数据)
MyExcel, varCells: Variant;
MySheet, MyCells, Cell1, Cell2, Range: OleVariant;
iRow, iCol, iSheetIdx, iVarCount, iCurRow: integer;
CurPos: TBookmark;
begin //返回导出记录条数
try
MyExcel := CreateOleObject('Excel.Application');
except
application.MessageBox('没有安装Excel','提示',mb_iconinformation);
Result:=0;
exit;
end;
MyExcel.WorkBooks.Add;
MyExcel.Visible := False;
//DataSet := dgrSource.DataSource.DataSet;
DataSet.DisableControls;
//CurPos := DataSet.GetBookmark;
DataSet.First;


DataSet.DisableControls;
CurPos := DataSet.GetBookmark;
DataSet.First;

MyExcel := CreateOleObject('Excel.Application');
MyExcel.WorkBooks.Add;
MyExcel.Visible := False;

if DataSet.RecordCount <= MAX_VAR_ONCE then
iVarCount := DataSet.RecordCount
else
iVarCount := MAX_VAR_ONCE;
varCells := VarArrayCreate([1,
iVarCount,
1,
DataSet.FieldCount], varVariant);
iSheetIdx := 1;
iRow := 0;
Result := 0;
while not DataSet.Eof do
begin
if (iRow = 0) or (iRow > MAX_SHEET_ROWS + 1) then
begin //新增一个Sheet
if iSheetIdx <= MyExcel.WorkBooks[1].WorkSheets.Count then
MySheet := MyExcel.WorkBooks[1].WorkSheets[iSheetIdx]
else
MySheet := MyExcel.WorkBooks[1].WorkSheets.Add(NULL, MySheet);//加在后面
MyCells := MySheet.Cells;
Inc(iSheetIdx);
iRow := 1;

for iCol := 1 to DataSet.FieldCount do
begin
MySheet.Cells[1, iCol].Font.Bold := True;
{MySheet.Select;
MySheet.Cells[iRow,iCol].Select;
MyExcel.Selection.Font.Bold := true;}//这种方法也可(Sheet.Select不可少)
MySheet.Cells[1, iCol] := DataSet.Fields[iCol-1].DisplayName;
MySheet.Columns[iCol].ColumnWidth :=DataSet.Fields[iCol-1].DisplayWidth;
if (DataSet.Fields[iCol - 1].DataType = ftString)
or (DataSet.Fields[iCol - 1].DataType = ftWideString) then
begin //对于“字符串”型数据则设Excel单元格为“文本”型
MySheet.Columns[iCol].NumberFormatLocal := '@';
end;
end;
Inc(iRow);
end;
iCurRow := 1;
while not DataSet.Eof do
begin
for iCol := 1 to DataSet.FieldCount do
begin
varCells[iCurRow, iCol] := DataSet.Fields[iCol-1].AsString;
end;
Inc(iRow);
Inc(iCurRow);
Inc(Result);
DataSet.Next;
if (iCurRow > iVarCount) or (iRow > MAX_SHEET_ROWS + 1) then
begin
if Assigned(UpAniInfo) then
UpAniInfo(Format('(已导出%d条)', [Result])); //显示已导出条数
Application.ProcessMessages;
Break;
end;
end;
Cell1 := MyCells.Item[iRow - iCurRow + 1, 1];
Cell2 := MyCells.Item[iRow - 1,
DataSet.FieldCount];
Range := MySheet.Range[Cell1 ,Cell2];
Range.Value := varCells;
if (iRow > MAX_SHEET_ROWS + 1) then //一个Sheet导出结束
begin
MySheet.Select;
MySheet.Cells[1, 1].Select; //使得每一Sheet均定位在第一格
end;
Cell1 := Unassigned;
Cell2 := Unassigned;
Range := Unassigned;

end;

MyCells := Unassigned;
varCells := Unassigned;
MyExcel.WorkBooks[1].WorkSheets[1].Select; //必须先选Sheet 2005.8.23
MyExcel.WorkBooks[1].WorkSheets[1].Cells[1,1].Select;
MyExcel.Visible := True;
MyExcel.WorkBooks[1].Saved := True;
MyExcel := Unassigned;
if CurPos <> nil then
begin
DataSet.GotoBookmark(CurPos);
DataSet.FreeBookmark(CurPos);
end;
DataSet.EnableControls;
end;
end.