一个通用的Delphi数据导出到Excel函数

关键字：delphi 对Excel编程，TDataSet（Tquery，TTabe）导到Excel，如何设置Excel字体、文本对齐方式，如何设置单元格边框，如何合并单元格，如何Excel打印设置，如何设置单元格为文本格式

主要功能：

1.数据集导出到Excel函数

2.自动设置列宽

3.自动调节适应A4纸张

4.具有打开Excel、打印预览、直接打印选项

unit ExcelReport;

interface

uses

SysUtils, Variants, Controls, Forms, Dialogs, ComObj, ComCtrls, DB, excel2000,

StdCtrls, Graphics, Windows, Grids;

{**************************************************************************************

数据集导出到Excel函数，自动设置列宽，自动调节适应A4纸张

Columns：可以是DataSet的Fields，ListView的Columns，StringGrid之一

DataSet：数据集

Caption：大标题，

SubCaption：子标题，

LeftCaption：左标题，

CenterCaption：中标题

RightCaption：右标题

Flag：1:预览，2:直接打印，0：打开Excel编辑

ColAutoSize：是否允许自动列宽

**************************************************************************************}

procedure DataSetToExcel(Columns: TObject; DataSet: TDataSet; Caption: String = '';

SubCaption: String = ''; LeftCaption: String = '';

CenterCaption: String = ''; RightCaption: String = '';

Flag: Integer = 1; ColAutoSize: Boolean = True);

implementation

procedure DataSetToExcel(Columns: TObject; DataSet: TDataSet; Caption: String = '';

SubCaption: String = ''; LeftCaption: String = '';

CenterCaption: String = ''; RightCaption: String = '';

Flag: Integer = 1; ColAutoSize: Boolean = True);

const

MaxColWidth = 80;

RowCaption = 1;

RowUse = 5;

FontSizeCaption = 15;

FontSizeSubCaption = 10;

FontSizeLeftCaption = 12;

FontSizeCenterCaption = 12;

FontSizeRightCaption = 12;

FontSizeColumns = 10;

FontSizeData = 10;

FontNameCaption = '楷体';

FontNameSubCaption = '宋体';

FontNameLeftCaption = '宋体';

FontNameCenterCaption = '宋体';

FontNameRightCaption = '宋体';

FontNameColumns = '宋体';

FontNameData = '宋体';

TextAlignLeft = 2;

TextAlignCenter = 3;

TextAlignRight = 4;

TextAlignTop = 1;

TextAlignVCenter = 2;

TextAlignBottom = 3;

var

Excel, Sheet: Variant;

RowIndex: Integer;

ColSum: Integer;

Form: TForm;

lb: TLabel;

function GetExcel(): Integer;

begin

Result := DataSet.RecordCount + RowUse;

if (Result > 65536 ) then

begin

if (MessageDlg(' 需要导出的数据过大，Excel最大只能容纳65536行，'+

#13'将会截断超过部分，是否还要继续？',

mtConfirmation, [mbYes, mbNo], 0) = mrNo) then

begin

Result := 0;

exit;

end else

Result := 65536;

end;

try

Excel := CreateOleobject('Excel.Application');

except

ShowMessage(#13' Excel没有正确安装！');

end;

end;

function GetColumnsWidth(): Integer;

var

i: Integer;

begin

Result := 0;

for i := 1 to ColSum do

Result := Result + Sheet.Columns[i].ColumnWidth;

Result := Excel.InchesToPoints((Result * 2.2862) / 25.4);

end;

procedure SetColumns( Columns: TListColumns); overload;

var

i: Integer;

s: String;

begin

for i := 0 to (Columns.Count - 1) do

begin

s := Columns[i].Caption;

Sheet.Columns[i + 1].ColumnWidth := Length(s);

Sheet.Cells[RowIndex, i + 1].value := s;

end;

end;

procedure SetColumns( Columns: TFields); overload;

var

i: Integer;

s: String;

begin

for i := 0 to (Columns.Count - 1) do

begin

s := Columns[i].FieldName;

Sheet.Columns[i + 1].ColumnWidth := Length(s);

Sheet.Cells[RowIndex, i + 1].value := s;

end;

end;

procedure SetColumns( Columns: TStringGrid); overload;

var

i: Integer;

s: String;

begin

for i := 1 to (Columns.ColCount - 1) do

begin

s := Columns.Cells[i, 0];

Sheet.Columns[i].ColumnWidth := Length(s);

Sheet.Cells[RowIndex, i].value := s;

end;

end;

procedure DoDataSetToExcel();

function GetDateTimeStr(DT: TDateTime): String;

var

nDT: Integer;

begin

Result := TimeToStr(DT);

nDT := Trunc(DT);

if nDT < 1000 then

begin

if nDT - 2 >= 1 then

Result := IntToStr(nDT - 2) + '天' + Result;

end else

Result := DateToStr(DT) + ' ' + Result;

end;

var

i, RowEnd, Len: Integer;

s: String;

begin

RowEnd := DataSet.RecordCount + RowIndex - 1;

if RowEnd > 65536 then

RowEnd := 65536;

DataSet.First();

while not DataSet.Eof do

begin

for i := 0 to DataSet.Fields.Count - 1 do

begin

if DataSet.Fields[i].DataType in [ftDateTime, ftDate, ftTime] then

begin

if DataSet.Fields[i].IsNull then

s := ''

else

s := GetDateTimeStr(DataSet.Fields[i].AsDateTime);

end else

s := DataSet.Fields[i].AsString;

if ColAutoSize then

begin

Len := Length(s) - 1;

if Len > MaxColWidth then

Len := MaxColWidth;

if Sheet.Columns[i + 1].ColumnWidth < Len then

Sheet.Columns[i + 1].ColumnWidth := Len;

end;

Sheet.Cells[RowIndex, i + 1].value := s;

end;

if RowIndex = RowEnd then

break;

if RowIndex mod 10 = 0 then

begin

lb.Caption := Format('正在导出数据，已经完成：%d', [Trunc(RowIndex / RowEnd * 100)]) + '%';

Form.Update();

Application.ProcessMessages();

end;

RowIndex := RowIndex + 1;

DataSet.Next();

end;

lb.Caption := '数据导出完毕......';

Form.Update();

end;

function RowColToStr( R1, C1, R2, C2: Integer): String;

function ColToStr(C: Integer): String;

var

nDiv: Integer;

begin

Result := '';

if C > 26 then

begin

nDiv := C div 26;

C := (C mod 26);

if C = 0 then

begin

C := 26;

nDiv := nDiv - 1;

end;

Result := Char(Integer('A') + nDiv);

end;

Result := Result + Char(Integer('A') + C - 1);

end;

begin

Result := ColToStr(C1) + IntToStr(R1) + ':' + ColToStr(C2) + IntToStr(R2);

end;

var

Range, RangeFind: Variant;

RowEnd: Integer;

function RepString(FindStr, ReplacedStr: String): Boolean;

begin

Result := False;

RangeFind := Excel.Cells.Find(FindStr, EmptyParam, xlFormulas, xlPart, xlByRows, xlNext, False, False);

try

RowIndex := RangeFind.Row;

RangeFind.Select;

Excel.ActiveCell.value := ReplacedStr;

Result := True;

except

end;

end;

procedure SetFormat();

var

i: Integer;

begin

for i := 0 to DataSet.Fields.Count - 1 do

begin

case DataSet.Fields[i].DataType of

ftSmallint, ftInteger, ftWord, ftAutoInc, ftLargeint:

begin

Range := Sheet.Range[RowColToStr(RowIndex, i + 1, RowEnd, i + 1)];

Range.HorizontalAlignment := TextAlignRight;

//Range.NumberFormat := '#,##0;-#,##0';

end;

ftFloat:

begin

Range := Sheet.Range[RowColToStr(RowIndex, i + 1, RowEnd, i + 1)];

Range.HorizontalAlignment := TextAlignRight;

Range.NumberFormat := '#,##0.000000;-#,##0.00000';

end;

ftDate, ftTime, ftDateTime:

begin

Range := Sheet.Range[RowColToStr(RowIndex, i + 1, RowEnd, i + 1)];

Range.HorizontalAlignment := TextAlignRight;

Range.NumberFormatLocal := '@';

if DataSet.Fields[i].AsDateTime < 1000 then

Sheet.Columns[i + 1].ColumnWidth := 9.1

else

Sheet.Columns[i + 1].ColumnWidth := 17;

end;

end;

end;

end;

procedure CheckPageWidth();

var

PageW, WordW, BorderMargin: Integer;

tmp: Integer;

i: Integer;

ftmp: real;

begin

if (xlPaperA4 = Sheet.PageSetup.PaperSize) and (xlPortrait = Sheet.PageSetup.Orientation) then

begin

BorderMargin := Sheet.PageSetup.LeftMargin * 2;

WordW := GetColumnsWidth();

PageW := Excel.InchesToPoints(21 / 2.54);

if WordW > PageW - BorderMargin then

begin

Sheet.PageSetup.Orientation := xlLandscape;

PageW := Excel.InchesToPoints(29.7 / 2.54);

tmp := PageW - WordW - BorderMargin;

ftmp := tmp / WordW;

if (tmp < 0) and (ftmp >= -0.15) then

begin

ftmp := 1 + ftmp;

for i := 1 to ColSum do

Sheet.Columns[i].ColumnWidth := Sheet.Columns[i].ColumnWidth * ftmp;

end;

end;

end;

end;

var

Workbook: Variant;

CursorSave: TCursor;

ColCenter: Integer;

FileName: String;

begin

ColSum := DataSet.Fields.Count;

if ColSum = 0 then

begin

ShowMessage(#13' 数据表的列数为0，无法导出！');

exit;

end;

CursorSave := Screen.Cursor;

Form := TForm.Create(nil);

Form.BorderStyle := bsNone;

Form.FormStyle := fsStayOnTop;

Form.Width := 300;

Form.Height := 90;

Form.Left := (Screen.Width - Form.Width) div 2;

Form.Top := (Screen.Height - Form.Height) div 2;

lb := TLabel.Create(Form);

lb.Parent := Form;

lb.AutoSize := False;

lb.Left := 5;

lb.Top := 35;

lb.Width := 290;

lb.Height := 30;

lb.Font.Size := 10;

lb.Font.Color := clBlue;

Form.Show();

try

Screen.Cursor := crHourGlass;

lb.Caption := '正在创建Excel......';

Form.Update();

RowEnd := GetExcel();

if RowEnd > 0 then

begin

try

try

lb.Caption := '正在打开Excel......';

Form.Update();

FileName := ExtractFileDir(Application.ExeName) + '\' + Caption + '_模板.xls';

if FileExists(FileName) then

begin

FileName := ExtractFileDir(Application.ExeName) + '\' + Caption + '.xls';

CopyFile(PChar(ExtractFileDir(Application.ExeName) + '\' + Caption + '_模板.xls'), PChar(FileName), False) ;

end else

FileName := '';

if FileName <> '' then

begin

Workbook := Excel.Workbooks.Open(FileName)

end else

begin

Workbook := Excel.Workbooks.Add;

Excel.WorkSheets[1].Name := Caption;

end;

Excel.WorkSheets[1].Activate;

Sheet := Excel.Workbooks[1].WorkSheets[1];

Sheet.Cells.NumberFormatLocal := '@';

RowIndex := RowCaption;

ColCenter := (ColSum + 1) div 2;

lb.Caption := '正在设置标题......';

Form.Update();

Sheet.Range['A1:A1'].Select;

if Caption <> '' then

begin

//设置标题

if (FileName = '') or (not RepString('%标题%', Caption)) then

begin

Range := Sheet.Range[RowColToStr(RowIndex, 1, RowIndex, ColSum)];

Range.NumberFormatLocal := '@';

Range.HorizontalAlignment := TextAlignCenter;

Range.VerticalAlignment := TextAlignVCenter;

Range.Characters.Font.Name := FontNameCaption;

Range.Characters.Font.FontStyle := '加粗';

Range.Characters.Font.Size := FontSizeCaption;

Sheet.Cells[RowIndex, ColCenter].value := Caption;

Range.Merge;

end;

end;

if SubCaption <> '' then

begin

//设置子标题

if (FileName = '') or (not RepString('%子标题%', SubCaption)) then

begin

RowIndex := RowIndex + 1;

Range := Sheet.Range[RowColToStr(RowIndex, 1, RowIndex, ColSum)];

Range.HorizontalAlignment := TextAlignCenter;

Range.VerticalAlignment := TextAlignTop;

Range.Characters.Font.Name := FontNameSubCaption;

Range.Characters.Font.FontStyle := '加粗';

Range.Characters.Font.Size := FontSizeSubCaption;

Sheet.Cells[RowIndex, ColCenter].value := SubCaption;

Range.Merge; //合并

RowIndex := RowIndex + 1;

end;

end;

if (FileName = '') then

begin

Sheet.Rows[Format('%d:%d', [RowIndex, RowIndex])].Select;

Excel.Selection.RowHeight := 8;

RowIndex := RowIndex + 1;

end;

if LeftCaption <> '' then

begin

//设置左标题

if (FileName = '') or (not RepString('%左标题%', LeftCaption)) then

begin

//设置左标题

Range := Sheet.Range[RowColToStr(RowIndex, 1, RowIndex, 1)];

Range.HorizontalAlignment := TextAlignLeft;

Range.Characters.Font.Name := FontNameLeftCaption;

Range.Characters.Font.FontStyle := '加粗';

Range.Characters.Font.Size := FontSizeLeftCaption;

Sheet.Cells[RowIndex, 1].value := LeftCaption;

end;

end;

if CenterCaption <> '' then

begin

//设置中标题

if (FileName = '') or (not RepString('%中标题%', CenterCaption)) then

begin

Range := Sheet.Range[RowColToStr(RowIndex, ColCenter, RowIndex, ColCenter)];

Range.HorizontalAlignment := TextAlignCenter;

Range.Characters.Font.Name := FontNameCenterCaption;

Range.Characters.Font.FontStyle := '加粗';

Range.Characters.Font.Size := FontSizeCenterCaption;

Sheet.Cells[RowIndex, ColCenter].value := CenterCaption;

end;

end;

if RightCaption <> '' then

begin

//设置右标题

if (FileName = '') or (not RepString('%右标题%', RightCaption)) then

begin

Range := Sheet.Range[RowColToStr(RowIndex, ColSum, RowIndex, ColSum)];

Range.HorizontalAlignment := TextAlignRight;

Range.Characters.Font.Name := FontNameRightCaption;

Range.Characters.Font.FontStyle := '加粗';

Range.Characters.Font.Size := FontSizeRightCaption;

Sheet.Cells[RowIndex, ColSum].value := RightCaption;

end;

end;

if RowIndex <> RowCaption then

RowIndex := RowIndex + 1;

//设置栏目字体

Range := Sheet.Range[RowColToStr(RowIndex, 1, RowIndex, ColSum)];

Range.Select;

if (FileName <> '') and RepString('%栏目%', '') then

begin

Range.Characters.Font.Name := RangeFind.Characters.Font.Name;

Range.Characters.Font.Size := RangeFind.Characters.Font.Size;

Range.HorizontalAlignment := RangeFind.HorizontalAlignment;

Range.Characters.Font.FontStyle := RangeFind.Characters.Font.FontStyle;

Range.Borders[1].Weight := RangeFind.Borders[1].Weight;

Range.Borders[2].Weight := RangeFind.Borders[2].Weight;

Range.Borders[3].Weight := RangeFind.Borders[3].Weight;

Range.Borders[4].Weight := RangeFind.Borders[4].Weight;

end else

begin

Range.Characters.Font.Name := FontNameColumns;

Range.Characters.Font.Size := FontSizeColumns;

Range.HorizontalAlignment := TextAlignCenter;

Range.Characters.Font.FontStyle := '加粗';

Range.Borders[1].Weight := 2;

Range.Borders[2].Weight := 2;

Range.Borders[3].Weight := 2;

Range.Borders[4].Weight := 2;

end;

Sheet.PageSetup.PrintTitleRows := Format('$%d:$%d', [RowIndex, RowIndex]);

lb.Caption := '正在设置栏目和数据区字体......';

Form.Update();

//设置栏目文字

if Columns is TFields then

SetColumns(TFields(Columns))

else

if Columns is TStringGrid then

SetColumns(TStringGrid(Columns))

else

if Columns is TListColumns then

SetColumns(TListColumns(Columns));

RowIndex := RowIndex + 1;

//设置数据字体

Range := Sheet.Range[RowColToStr(RowIndex, 1, RowEnd, ColSum)];

Range.Select;

if (FileName <> '') and RepString('%数据%', '') then

begin

Range.Characters.Font.Name := RangeFind.Characters.Font.Name;

Range.Characters.Font.Size := RangeFind.Characters.Font.Size;

Range.HorizontalAlignment := RangeFind.HorizontalAlignment;

Range.Characters.Font.FontStyle := RangeFind.Characters.Font.FontStyle;

Range.Borders[1].Weight := RangeFind.Borders[1].Weight;

Range.Borders[2].Weight := RangeFind.Borders[2].Weight;

Range.Borders[3].Weight := RangeFind.Borders[3].Weight;

Range.Borders[4].Weight := RangeFind.Borders[4].Weight;

end else

begin

Range.Characters.Font.Name := FontNameData;

Range.Characters.Font.Size := FontSizeData;

Range.Borders[1].Weight := 2;

Range.Borders[2].Weight := 2;

Range.Borders[3].Weight := 2;

Range.Borders[4].Weight := 2;

end;

//设置数字栏显示格式

if FileName = '' then

SetFormat();

//加载数据到Excel

lb.Caption := '正在导出数据......';

Form.Update();

DoDataSetToExcel();

Sheet.Range['A1:A1'].Select;

if FileName = '' then

begin

Sheet.PageSetup.LeftMargin := Excel.InchesToPoints(0.590551181102362);//Excel.InchesToPoints(0.393700787401575);

Sheet.PageSetup.RightMargin := Sheet.PageSetup.LeftMargin;

Sheet.PageSetup.TopMargin := Sheet.PageSetup.LeftMargin;

Sheet.PageSetup.BottomMargin := Sheet.PageSetup.LeftMargin;

Sheet.PageSetup.CenterHorizontally := True;

Sheet.PageSetup.CenterVertically := True;

Sheet.PageSetup.CenterFooter := '第 &P 页，共 &N 页';

end;

CheckPageWidth();

case Flag of

1: //打印预览

begin

Excel.Visible := True;

Form.Hide();

Workbook.Saved := True;

Excel.DisplayAlerts := False;

Sheet.PrintPreview;

Excel.Visible := False;

Excel.Quit;

end;

2: //直接打印

begin

Form.Hide();

Sheet.PrintOut;

Workbook.Saved := True;

Excel.DisplayAlerts := False;

Excel.Quit;

end;

else //打开Excel编辑

Form.Hide();

Excel.Visible := True;

end;

except

Workbook.Saved := True;

Excel.DisplayAlerts := False;

Excel.Quit;

end;

finally

Excel := UnAssigned;

end;

end;

finally

lb.Destroy();

Form.Destroy();

Screen.Cursor := CursorSave;

end;

end;

end.