参看如下码:
function DBGridExp_EXC_formate(DBGD:TDBgrid):boolean;
{将DBGD中数据导出成excel文件快速带格式-2003 by 白忙剩人}
var
i,hang,lie:integer;
datas:Variant;
PDBset:^TADODataSet;
st:string;
I_width:extended;
ExcelApp,MyWorkBook,EWorksheet:Variant;
c:Tcolor;
begin
result:=false;
st:=''; // clred
hang:=1;
lie:=0;
PDBset:=@DBGD.DataSource.DataSet;
if PDBset.RecordCount>65530 then
if messageDlg('数据行数可能超过EXCEL最大限制,是否改用文本导出,忽略限制按NO',
mtWarning ,[mbYes,mbNo], 0)=mrYes then exit;
//----------------------test start------
try
ExcelApp:=CreateOleObject('Excel.Application');
MyWorkBook:=CreateOleobject('Excel.Sheet');
except
on Exception do raise exception.Create('无法打开Xls文件,请确认已 经安装EXCEL')
end;
// ExcelApp.Visible := true;
MyworkBook:=ExcelApp.workBooks.Add;
// MyworkBook.Activate;
EWorksheet:=Myworkbook.worksheets[1];
// ---------------- test end----------
try
for i:=0 to PDBset.FieldCount-1 do
if DBGD.Columns.Visible then
begin
inc(lie);
ExcelApp.Range[EWorksheet.Cells[hang,lie],
EWorksheet.Cells[hang,lie]].Select;
c:=DBGD.Columns.Title.Color;
ExcelApp.Selection.Interior.Color:= ColorToRGB(c);
ExcelApp.Selection.HorizontalAlignment:=
GetExcelAlignment(DBGD.Columns.Title.Alignment);
ExcelApp.Selection.font.FontStyle:=
GetExcelFontStyle(DBGD.Columns.Title.Font.Style);
if fsUnderline in DBGD.Columns.Title.Font.Style then
ExcelApp.Selection.font.Underline := xlUnderlineStyleSingle
else ExcelApp.Selection.font.Underline :=xlUnderlineStyleNone;
//------
if fsStrikeOut in DBGD.Columns.Title.Font.Style then
ExcelApp.Selection.font.Strikethrough:= True
else ExcelApp.Selection.font.Strikethrough:= false;
st:=DBGD.Columns.Title.Caption;
I_width:=DBGD.Columns.Width/8.5;
if I_width>255 then I_width:=255;
if I_width<0 then I_width:=0;
EWorksheet.Columns[lie].ColumnWidth := I_width;
EWorksheet.Range[EWorksheet.Cells[hang,lie],
EWorksheet.Cells[hang,lie]].Font.Color:=
DBGD.Columns.Title.Font.Color;
EWorksheet.Range[EWorksheet.Cells[hang,lie],
EWorksheet.Cells[hang,lie]].font.Size:=
DBGD.Columns.Title.Font.Size;
EWorksheet.Range[EWorksheet.Cells[hang,lie],
EWorksheet.Cells[hang,lie]].font.Name:=
DBGD.Columns.Title.Font.Name;
// EWorksheet.Range[EWorksheet.Cells[hang,lie],
// EWorksheet.Cells[hang,lie]].
EWorksheet.Cells[hang,lie].Value :=st;
st:=PDBset.Fields.ClassName;
ExcelApp.Range[EWorksheet.Cells[hang+1,lie],
EWorksheet.Cells[PDBset.RecordCount+1,lie]].select;
if (st='TDateField') or (st='TDateTimeField') then
ExcelApp.Selection.NumberFormatLocal:= '[$-F800]dddd, mmmm dd, yyyy'
else if (st='TStringField') or (st='TWideStringField') then
ExcelApp.Selection.NumberFormatLocal:='@';
c:=DBGD.Columns.Color;
ExcelApp.Selection.Interior.Color:=ColorToRGB(c);
ExcelApp.Selection.HorizontalAlignment:=
GetExcelAlignment(DBGD.Columns.Alignment);
ExcelApp.Selection.font.FontStyle:=
GetExcelFontStyle(DBGD.Columns.Font.Style);
if fsUnderline in DBGD.Columns.Font.Style then
ExcelApp.Selection.font.Underline := xlUnderlineStyleSingle
else ExcelApp.Selection.font.Underline :=xlUnderlineStyleNone;
//----------
if fsStrikeOut in DBGD.Columns.Font.Style then
ExcelApp.Selection.font.Strikethrough:= True
else ExcelApp.Selection.font.Strikethrough:= false;
EWorksheet.Range[EWorksheet.Cells[hang+1,lie],
EWorksheet.Cells[PDBset.RecordCount+1,lie]].Font.Color:=
DBGD.Columns.Font.Color;
EWorksheet.Range[EWorksheet.Cells[hang+1,lie],
EWorksheet.Cells[PDBset.RecordCount+1,lie]].font.Size:=
DBGD.Columns.Font.Size;
EWorksheet.Range[EWorksheet.Cells[hang+1,lie],
EWorksheet.Cells[PDBset.RecordCount+1,lie]].font.Name:=
DBGD.Columns.Font.Name;
end; //end for i:=0 to PDBset.FieldCount-1
datas:=varArrayCreate([1,PDBset.RecordCount,1,lie],varVariant);
PDBset.First;
PDBset.DisableControls;
while not PDBset.Eof do
begin
inc(hang);
lie:=0;
for i:=0 to PDBset.FieldCount-1 do
if DBGD.Columns.Visible then
begin
inc(lie);
datas[hang-1,lie]:=PDBset.Fields.Value;
end; //end for i:=0 to PDBset.FieldCount-1
PDBset.Next;
end;// while not PDBset.Eof
//-------设置borders-------
EWorksheet.Range[EWorksheet.cells[1,1],
EWorksheet.cells[PDBset.RecordCount+1,lie]].select;
ExcelApp.Selection.Borders[xlDiagonalDown].LineStyle := xlNone;
ExcelApp.Selection.Borders[xlDiagonalUp].LineStyle := xlNone ;
ExcelApp.Selection.Borders[xlEdgeLeft].LineStyle := xlContinuous;
ExcelApp.Selection.Borders[xlEdgeLeft].Weight := xlHairline;
ExcelApp.Selection.Borders[xlEdgeLeft].ColorIndex := xlAutomatic;
ExcelApp.Selection.Borders[xlEdgeTop].LineStyle := xlContinuous;
ExcelApp.Selection.Borders[xlEdgeTop].Weight := xlHairline;
ExcelApp.Selection.Borders[xlEdgeTop].ColorIndex := xlAutomatic;
ExcelApp.Selection.Borders[xlEdgeBottom].LineStyle := xlContinuous;
ExcelApp.Selection.Borders[xlEdgeBottom].Weight := xlHairline;
ExcelApp.Selection.Borders[xlEdgeBottom].ColorIndex := xlAutomatic;
ExcelApp.Selection.Borders[xlEdgeRight].LineStyle := xlContinuous;
ExcelApp.Selection.Borders[xlEdgeRight].Weight := xlHairline;
ExcelApp.Selection.Borders[xlEdgeRight].ColorIndex := xlAutomatic;
if (dgColLines in DBGD.Options) then
begin
ExcelApp.Selection.Borders[xlInsideVertical].LineStyle := xlContinuous;
ExcelApp.Selection.Borders[xlInsideVertical].Weight := xlHairline;
ExcelApp.Selection.Borders[xlInsideVertical].ColorIndex := xlAutomatic;
end;
if (dgRowLines in DBGD.Options) then
begin
ExcelApp.Selection.Borders[xlInsideHorizontal].LineStyle := xlContinuous;
ExcelApp.Selection.Borders[xlInsideHorizontal].Weight := xlHairline;
ExcelApp.Selection.Borders[xlInsideHorizontal].ColorIndex := xlAutomatic;
end;
//------end 设置borders-------
EWorksheet.Range[EWorksheet.cells[2,1],
EWorksheet.cells[PDBset.RecordCount+1,lie]].Value2:=datas;
result:=true;
ExcelApp.Range[EWorksheet.Cells[1,1],
EWorksheet.Cells[1,1]].select ;
// ExcelApp.Visible := true;
finally
ExcelApp.Visible := true;
PDBset.EnableControls;
datas:=Unassigned;
// ExcelApp.quit;
ExcelApp:=Unassigned;
MyWorkBook:=Unassigned;
EWorksheet:=Unassigned;
end;
end;