delphi TDBGridEh 导出excel的另外一种方式

 一般用自带的导出,速度快,但是有的时候需要导出正规xls

procedure TF240090.ExportToExcel3(dbgrideh1: TDBGridEh; TitleName: string; autoFit: Boolean);

  function isFloat(str: string): Boolean;
  begin
    try
      StrToFloat(str);
    except
      Result := False;
    end;
    Result := True;
  end;

  function getSpecCount(substr, str: string): integer;
  var
    i, count: integer;
  begin
    i := 0;
    count := 1;
    while pos(substr, str) > 0 do
    begin
      i := pos(substr, str);
      count := count + 1;
      str := RightStr(str, length(str) - i);
    end;
    result := count;
  end;

  function getSpaceI(sheet: Variant; row, col: integer): Integer;
  var
    i: integer;
  begin
    for i := row downto 2 do//首行为标题行
      if sheet.cells[i, col].Value <> '' then
        break;
    result := i;
  end;

var
  XLApp: Variant;
  Sheet: Variant;
  s1, s2: string;
  Caption: string;
  Row, Col: integer;
  iCount, jCount: Integer;
  FBookMark: TBookmark;
  FileName: string;
  SaveDialog1: TSaveDialog;
  i, ii, max: Integer;
  ti: TColumnTitleEh;
begin //如果数据集为空或没有打开则退出
  if not dbgrideh1.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;
  Application.ProcessMessages;
  Screen.Cursor := crHourGlass; //鼠标指针为沙漏状
  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;
  //XLApp.Visible := True; //调试显示用
  XLApp.WorkBooks.Add;
  Sheet := XLApp.WorkSheets[1]; //写标题
  Sheet.name :=  TitleName;
  Sheet.range[Sheet.cells[1, 1], Sheet.cells[1, dbgrideh1.Columns.Count]].Select; //选择该列
  XLApp.selection.HorizontalAlignment := 3; //居中


//  XLApp.selection.MergeCells := True;  //合并 //写表头

  Row := 1;
  for i := 0 to dbgrideh1.Columns.Count - 1 do
  begin
    ti := dbgrideh1.Columns[i].Title;
    ii := getSpecCount('|', ti.Caption) + 1;
    if max < ii then
      max := ii;
  end;
  jCount := max;
  for iCount := 0 to dbgrideh1.Columns.Count - 1 do
  begin
    Col := 1;
    Row := iCount + 1;
    Caption := dbgrideh1.Columns[iCount].Title.Caption;

       Sheet.cells[Col, Row] := Caption;

  end;

  dbgrideh1.DataSource.DataSet.DisableControls;
  FBookMark := dbgrideh1.DataSource.DataSet.GetBookmark;
  dbgrideh1.DataSource.DataSet.First;
  while not dbgrideh1.DataSource.DataSet.Eof do
  begin
    for iCount := 1 to dbgrideh1.Columns.Count do
    begin
      Sheet.cells[jCount, iCount] := dbgrideh1.Columns.Items[iCount - 1].Field.AsString;
      if (Pos('.', dbgrideh1.Columns.Items[iCount - 1].Field.AsString) > 0) and isFloat(dbgrideh1.Columns.Items[iCount - 1].Field.AsString) then
        Sheet.cells[jCount, iCount].numberformatlocal := OleVariant('0.00');
    end;
    Inc(jCount);
    dbgrideh1.DataSource.DataSet.Next;
  end;
  if dbgrideh1.DataSource.DataSet.BookmarkValid(FBookMark) then
    dbgrideh1.DataSource.DataSet.GotoBookmark(FBookMark);
  dbgrideh1.DataSource.DataSet.EnableControls; //读取表脚
  if dbgrideh1.FooterRowCount > 0 then
  begin
    for Row := 0 to dbgrideh1.FooterRowCount - 1 do
    begin
      for Col := 0 to dbgrideh1.Columns.Count - 1 do
        Sheet.cells[jCount, Col + 1] := dbgrideh1.GetFooterValue(Row, dbgrideh1.Columns[Col]);
      Inc(jCount);
    end;
  end; //调整列宽
  if autoFit then
    for iCount := 1 to dbgrideh1.Columns.Count do
      Sheet.Columns[iCount].EntireColumn.AutoFit;
  Sheet.cells[1, 1].Select;
  XLApp.Visible := True;
  XLApp.Workbooks[1].SaveAs(FileName);
  XLApp := Unassigned;
  Screen.Cursor := crDefault;
end;
发布了90 篇原创文章 · 获赞 33 · 访问量 21万+

猜你喜欢

转载自blog.csdn.net/y281252548/article/details/98487755
今日推荐