delphi DBGridEhToExcel 单元文件  
官方Delphi 学习QQ群： 682628230（三千人）
频道

  1. 人气：
  2. 放大
  3. 缩小
  4. 二维码
  5. 赞赏

delphi DBGridEhToExcel 单元文件

unit DBGridEhToExcel;

interface

uses
  SysUtils, Variants, Classes, Graphics, Controls, Forms, Excel2000, ComObj,
  Dialogs, DB, DBGridEh, windows,ComCtrls,ExtCtrls;

type
 
TDBGridEhToExcel = class(TComponent)
private
    FProgressForm: TForm;                                  {进度窗体}
    FtempGauge: TProgressBar;                           {进度条}
    FShowProgress: Boolean;                                {是否显示进度窗体}
    FShowOpenExcel:Boolean;                                {是否导出后打开Excel文件}
    FDBGridEh: TDBGridEh;
    FTitleName: TCaption;                                  {Excel文件标题}
    FUserName: TCaption;                                   {制表人}
    procedure SetShowProgress(const Value: Boolean);       {是否显示进度条}
    procedure SetShowOpenExcel(const Value: Boolean);      {是否打开生成的Excel文件}
    procedure SetDBGridEh(const Value: TDBGridEh);
    procedure SetTitleName(const Value: TCaption);         {标题名称}
    procedure SetUserName(const Value: TCaption);          {使用人名称}
    procedure CreateProcessForm(AOwner: TComponent);       {生成进度窗体}
public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExportToExcel; {输出Excel文件}
published
    property DBGridEh: TDBGridEh read FDBGridEh write SetDBGridEh;
    property ShowProgress: Boolean read FShowProgress write SetShowProgress;    //是否显示进度条
    property ShowOpenExcel: Boolean read FShowOpenExcel write SetShowOpenExcel; //是否打开Excel
    property TitleName: TCaption read FTitleName write SetTitleName;
    property UserName: TCaption read FUserName write SetUserName;
end;
 
implementation

uses
    DBGridEhImpExp;
 
constructor TDBGridEhToExcel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FShowProgress := True;
  FShowOpenExcel:= True;
end;
 
procedure TDBGridEhToExcel.SetShowProgress(const Value: Boolean);
begin
  FShowProgress := Value;
end;
 
procedure TDBGridEhToExcel.SetDBGridEh(const Value: TDBGridEh);
begin
FDBGridEh := Value;
end;
 
procedure TDBGridEhToExcel.SetTitleName(const Value: TCaption);
begin
FTitleName := Value;
end;
 
procedure TDBGridEhToExcel.SetUserName(const Value: TCaption);
begin
FUserName := Value;
end;
 
function IsFileInUse(fName: string ): boolean;
var
  HFileRes: HFILE;
begin
  Result :=false;
  if not FileExists(fName) then exit;
  HFileRes :=CreateFile(pchar(fName), GENERIC_READ
               or GENERIC_WRITE,0, nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL, 0);
  Result :=(HFileRes=INVALID_HANDLE_VALUE);
  if not Result then
      CloseHandle(HFileRes);
end;
 
procedure TDBGridEhToExcel.ExportToExcel;
var
  ExpClass: TDBGridEhExportClass;
  Ext: string;
  SaveDlg: TSaveDialog;
  ExportAll: Boolean;
begin
  ExportAll := True; //缺省情况下导出所有数据
  SaveDlg := TSaveDialog.Create(Application);
  SaveDlg.Filter := 'Excel表格(*.XLS)|*.XLS|HTML文档(*.HTM)|*.HTM|RTF格式(*.RTF)|*.RTF|纯文本文件(*.TXT)|*.TXT|逗号分隔文本格式(*.CSV)|*.CSV';
  SaveDlg.FileName := '未命名';
  SaveDlg.Options := [ofOverwritePrompt, ofHideReadOnly, ofEnableSizing];
  if SaveDlg.Execute then
    begin
      case SaveDlg.FilterIndex of
        1:
          begin
            ExpClass := TDBGridEhExportAsXLS;
            Ext := 'xls';
          end;
        2:
          begin
            ExpClass := TDBGridEhExportAsHTML;
            Ext := 'htm';
          end;
        3:
          begin
            ExpClass := TDBGridEhExportAsRTF;
            Ext := 'rtf';
          end;
        4:
          begin
            ExpClass := TDBGridEhExportAsText;
            Ext := 'txt';
          end;
        5:
          begin
            ExpClass := TDBGridEhExportAsCSV;
            Ext := 'csv';
          end;
      else
        ExpClass := nil;
        Ext := '';
      end;

      if ExpClass <> nil then
      begin
        if UpperCase(Copy(SaveDlg.FileName, Length(SaveDlg.FileName) - 2, 3)) <> UpperCase(Ext) then
          SaveDlg.FileName := SaveDlg.FileName + '.' + Ext;
                //如果grid中有选择的区域，则只导出所选择的区域
        if DBGridEh.Selection.SelectionType <> gstNon then ExportAll := False;
        try
          SaveDBGridEhToExportFile(ExpClass, DBGridEh, SaveDlg.FileName, ExportAll);
          //读取数据
          DBGridEh.DataSource.DataSet.DisableControls;
          DBGridEh.DataSource.DataSet.First;
          while not DBGridEh.DataSource.DataSet.Eof do
          begin
              //显示进度条进度过程
              if ShowProgress then
              begin
                  FtempGauge.Position := DBGridEh.DataSource.DataSet.RecNo;
                  FtempGauge.Refresh;
              end;

              DBGridEh.DataSource.DataSet.Next;
          end;

        except
          on E: Exception do
            begin
              MessageBox(0, LPCTSTR('保存文件发生异常,请检查是否有重名文件并且该文件没有被打开!'), '注意', MB_OK or MB_ICONWARNING);
              Exit;
            end;
        end;
      end;
    end;
end;

{

var
  XLApp: Variant;
  Sheet: Variant;
  s1, s2: string;
  Caption,Msg: String;
  Row, Col: integer;
  iCount, jCount: Integer;
  FBookMark: TBookmark;
  FileName: String;
  SaveDialog1: TSaveDialog;
begin
    //如果数据集为空或没有打开则退出
    if not DBGridEh.DataSource.DataSet.Active then Exit;
 
    SaveDialog1 := TSaveDialog.Create(Nil);
    SaveDialog1.FileName := TitleName + '_' + FormatDateTime('YYMMDDHHmmSS', now);
    SaveDialog1.Filter := 'Excel文件|*.xls';
    if SaveDialog1.Execute then
        FileName := SaveDialog1.FileName;
    SaveDialog1.Free;
    if FileName = '' then Exit;
 
    while IsFileInUse(FileName) do
    begin
      if Application.MessageBox('目标文件使用中，请退出目标文件后点击确定继续！',
        '注意', MB_OKCANCEL + MB_ICONWARNING) = IDOK then
      begin
 
      end
      else
      begin
        Exit;
      end;
    end;
 
    if FileExists(FileName) then
    begin
      Msg := '已存在文件（' + FileName + '），是否覆盖？';
      if Application.MessageBox(PChar(Msg), '提示', MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2) = IDYES then
      begin
   //删除文件
        DeleteFile(PChar(FileName))
      end
      else
        exit;
    end;
    Application.ProcessMessages;
 
    Screen.Cursor := crHourGlass;
    //显示进度窗体
    if ShowProgress then
        CreateProcessForm(nil);
   
    if not VarIsEmpty(XLApp) then
    begin
        XLApp.DisplayAlerts := False;
        XLApp.Quit;
        VarClear(XLApp);
    end;
 
    //通过ole创建Excel对象
    try
        XLApp := CreateOleObject('Excel.Application');
    except
        MessageDlg('创建Excel对象失败，请检查你的系统是否正确安装了Excel软件！', mtError, [mbOk], 0);
        Screen.Cursor := crDefault;
        Exit;
    end;

    //生成工作页
    XLApp.WorkBooks.Add[XLWBatWorksheet];
    XLApp.WorkBooks[1].WorkSheets[1].Name := TitleName;
    Sheet := XLApp.Workbooks[1].WorkSheets[TitleName];

    //写标题
    sheet.cells[1, 1] := TitleName;
    sheet.range[sheet.cells[1, 1], sheet.cells[1, DBGridEh.Columns.Count]].Select; //选择该列

    XLApp.selection.HorizontalAlignment := $FFFFEFF4;                               //居中
    XLApp.selection.MergeCells := True;                                             //合并
 
    //写表头
    Row := 1;
    jCount := 3;
    for iCount := 0 to DBGridEh.Columns.Count - 1 do
    begin
        Col := 2;
        Row := iCount+1;
        Caption := DBGridEh.Columns[iCount].Title.Caption;
        while POS('|', Caption) > 0 do
        begin
            jCount := 4;
            s1 := Copy(Caption, 1, Pos('|',Caption)-1);
            if s2 = s1 then
            begin
                sheet.range[sheet.cells[Col, Row-1],sheet.cells[Col, Row]].Select;
                XLApp.selection.HorizontalAlignment := $FFFFEFF4;
                XLApp.selection.MergeCells := True;
            end
            else
                Sheet.cells[Col,Row] := Copy(Caption, 1, Pos('|',Caption)-1);
            Caption := Copy(Caption,Pos('|', Caption)+1, Length(Caption));
            Inc(Col);
            s2 := s1;
        end;
        Sheet.cells[Col, Row] := Caption;
        Inc(Row);
    end;
 
    //合并表头并居中
    if jCount = 4 then
        for iCount := 1 to DBGridEh.Columns.Count do
            if Sheet.cells[3, iCount].Value = '' then
            begin
                sheet.range[sheet.cells[2, iCount],sheet.cells[3, iCount]].Select;
                XLApp.selection.HorizontalAlignment := $FFFFEFF4;
                XLApp.selection.MergeCells := True;
            end
            else begin
                sheet.cells[3, iCount].Select;
                XLApp.selection.HorizontalAlignment := $FFFFEFF4;
            end;
 
    //读取数据
    DBGridEh.DataSource.DataSet.DisableControls;
    //FBookMark := DBGridEh.DataSource.DataSet.GetBookmark;
    DBGridEh.DataSource.DataSet.First;
    while not DBGridEh.DataSource.DataSet.Eof do
    begin
 
        for iCount := 1 to DBGridEh.Columns.Count do
        begin
            //Sheet.cells[jCount, iCount] :=DBGridEh.Columns.Items[iCount-1].Field.AsString;
 
 
          case DBGridEh.DataSource.DataSet.FieldByName(DBGridEh.Columns.Items[iCount-1].FieldName).DataType of
            ftSmallint, ftInteger, ftWord, ftAutoInc, ftBytes:
              Sheet.cells[jCount, iCount] :=DBGridEh.Columns.Items[iCount-1].Field.asinteger;
            ftFloat, ftCurrency, ftBCD:
              Sheet.cells[jCount, iCount] :=DBGridEh.Columns.Items[iCount-1].Field.AsFloat;
          else
            if DBGridEh.DataSource.DataSet.FieldByName(DBGridEh.Columns.Items[iCount-1].FieldName) is TBlobfield then // 此类型的字段(图像等)暂无法读取显示
              Sheet.cells[jCount, iCount] :=DBGridEh.Columns.Items[iCount-1].Field.AsString
            else
              Sheet.cells[jCount, iCount] :=''''+DBGridEh.Columns.Items[iCount-1].Field.AsString;
          end;
         
        end;
        Inc(jCount);
 
        //显示进度条进度过程
        if ShowProgress then
        begin
            FtempGauge.Position := DBGridEh.DataSource.DataSet.RecNo;
            FtempGauge.Refresh;
        end;
 
        DBGridEh.DataSource.DataSet.Next;
    end;

//    if DBGridEh.DataSource.DataSet.BookmarkValid(FBookMark) then
//        DBGridEh.DataSource.DataSet.GotoBookmark(FBookMark);

    DBGridEh.DataSource.DataSet.EnableControls;
 
    //读取表脚
    if DBGridEh.FooterRowCount > 0 then
    begin
        for Row := 0 to DBGridEh.FooterRowCount-1 do
        begin
            for Col := 0 to DBGridEh.Columns.Count-1 do
                Sheet.cells[jCount, Col+1] := DBGridEh.GetFooterValue(Row,DBGridEh.Columns[Col]);
            Inc(jCount);
        end;
    end;
 
    //调整列宽
//    for iCount := 1 to DBGridEh.Columns.Count do
//        Sheet.Columns[iCount].EntireColumn.AutoFit;
 
    sheet.cells[1, 1].Select;
    XlApp.Workbooks[1].SaveAs(FileName);
 
    XlApp.Visible := True;
    XlApp := Unassigned;
 
    if ShowProgress then
        FreeAndNil(FProgressForm);
    Screen.Cursor := crDefault;
   
end;
}
destructor TDBGridEhToExcel.Destroy;
begin
inherited Destroy;
end;
 
procedure TDBGridEhToExcel.CreateProcessForm(AOwner: TComponent);
var
  Panel: TPanel;
begin
  if Assigned(FProgressForm) then
       exit;
 
  FProgressForm := TForm.Create(AOwner);
  with FProgressForm do
  begin
      try
        Font.Name := '宋体';                                  {设置字体}
        Font.Size := 10;
        BorderStyle := bsNone;
        Width := 300;
        Height := 30;
        BorderWidth := 1;
        Color := clBlack;
        Position := poScreenCenter;
        Panel := TPanel.Create(FProgressForm);
        with Panel do
        begin
          Parent := FProgressForm;
          Align := alClient;
          Caption := '正在导出Excel，请稍候......';
          Color:=$00E9E5E0;
       end;
        FtempGauge:=TProgressBar.Create(Panel);
        with FtempGauge do
        begin
          Parent := Panel;
          Align:=alClient;
          Min := 0;
          Max:= DBGridEh.DataSource.DataSet.RecordCount;
          Position := 0;
        end;
      except
 
      end;
  end;
  FProgressForm.Show;
  FProgressForm.Update;
end;
 
procedure TDBGridEhToExcel.SetShowOpenExcel(const Value: Boolean);
begin
   FShowOpenExcel:=Value;
end;
 
end.

推荐分享
最新信息 delphi13 多线程优化 TThreade... delphi 如何 FastMM配置 delphi13 FireDAC增强 并行备份... delphi12 Embarcadero ld... delphi 查看 cpu 核心数
热门信息 delphi 动态数组的使用 delphi多线程TThread详解 delphi try except语句 和 try finally语... delphi中常用字符串处理函数 delphi Inc函数和Dec函数的用法
推荐区 txt文本处理 查询128 说一段 简搜 短笑话 IP查询 正则大全 在线加密解密工具 在线文本筛选工具 1234828网址导航 windows库
图文皆来源于网络，内容仅做公益性分享，版权归原作者所有，如有侵权请告知删除！
  1. 关于我们
  2. 联系我们
 

Copyright © 2014 DelphiW.com 开发 源码 文档 技巧 All Rights Reserved
晋ICP备14006235号-8 晋公网安备 14108102000087号

执行时间: 0.046715974807739 seconds