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

OStack程序员社区-中国程序员成长平台 › 门户 › 编程›综合其他

原作者: [db:作者] 来自: [db:来源] 收藏邀请

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

(2008-05-09 21:10:07)

关键字：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

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.

鲜花

握手

雷人

路过

鸡蛋

该文章已有0人参与评论

请发表评论

全部评论

专题导读

More+

10-27 六六分期app的软件客服如何联系？(六六分期

11-06 可心卡盟:win10系统火狐flash插件崩溃怎么

11-06 亲亲特价:怎么删除回收站图标

11-06 济南大学虚拟社区:鲁大师节能降温的具体办

11-06 xlueops.exe:无线网络安装向导

11-06 女斗合众国:win7系统cf与主机连接不稳定怎

11-06 0xc000022-[cf烟雾头]cf怎么调烟雾头

11-06 qizideyouhuo:应用程序无法正常启动0xc0000

11-06 ipz-185:win7系统vcf文件怎么打开

11-06 傻哥蹦迪:win10系统s4怎么打开usb调试

11-06 八神浩树gtaste:回收站清空了怎么恢复

11-06 妖尾之黑色守护:win10系统电脑没有1440x900

11-06 校园至尊魔王小说:win7系统浏览网页时字体

11-06 女斗合众国:win10系统访问共享文件夹提示请

11-06 tokyo hot n0654:恢复win7系统默认字体一招

11-06 雨酷仙境:设置win7系统转移临时文件夹腾出

11-06 阿穆纳伊之杖:win7系统开始菜单在右边还原

11-06 tunespotting:win10系统火狐flash插件总是

11-06 甘尔葛分析师：计谋网站seo关键词暴涨有什

11-06 蔡贵霖: 计谋网站seo关键词暴涨有什么秘密

11-06 博益网首页:ao3网页版进入不了解决方法

11-06 漏斗子专栏: 网站数据分析小白易懂精华篇

11-06 见证双虹怎么做:win7系统开启telnet命令的

11-06 颾狐蝶蜋:系统资源不足无法完成请求的服务

11-06 国光中学校歌:提交网站到alexa查询详细步骤

11-06 西安有情天:静态网页和动态网页的区别

11-06 红木雅尚斋:外部链接构造对网站的好处

11-06 前官礼遇：防止域名劫持–增强域安全性的10

11-06 密传二转答案: 中文分词算法有哪些

11-06 金泉家园邮编:百度快照劫持的表现及应对方

delphi判断一个字符串是否只由数字组成发布时间：2022-07-18

[转]李战大师-悟透delphi-第四章接口发布时间：2022-07-18

剪的笔顺,诠释剪的笔画,认识剪的部首

1 六六分期app的软件客服如何联系？(六六分期

六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期

阅读：19224|2023-10-27

2 可心卡盟:win10系统火狐flash插件崩溃怎么

今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知

阅读：9996|2022-11-06

3 亲亲特价:怎么删除回收站图标

今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道

阅读：8331|2022-11-06

4 济南大学虚拟社区:鲁大师节能降温的具体办

今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要

阅读：8700|2022-11-06

5 xlueops.exe:无线网络安装向导

我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多

阅读：8645|2022-11-06

6 女斗合众国:win7系统cf与主机连接不稳定怎

今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不

阅读：9666|2022-11-06

7 0xc000022-[cf烟雾头]cf怎么调烟雾头

电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很

阅读：8630|2022-11-06

8 qizideyouhuo:应用程序无法正常启动0xc0000

我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法

阅读：8004|2022-11-06

9 ipz-185:win7系统vcf文件怎么打开

今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win

阅读：8664|2022-11-06

10 傻哥蹦迪:win10系统s4怎么打开usb调试

今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎

阅读：7539|2022-11-06

客服电话

电子邮件

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