excelwithodbc.pas

将DataGrid或dxDbGrid或cxGrid或数据集中的数据导出到Excel表格中

//通过Odbc导出到Excel
//周洋平
unit ExcelWithOdbc;

interface

uses
  Windows, Messages, SysUtils, Classes, ADODB, DBGrids, Forms, Dialogs,
  ShellAPI, DB, Controls, dxDBGrid;

type
  TExcelWithOdbc = class;
  {TDataItem}
  TDataItem = class(TCollectionItem)
  private
    { Private declarations }
    FSheetName: string;
    FDataSet: TCustomAdoDataSet;
    FDBGrid: TDBGrid;
    FDxDBGrid: TDxDBGrid;
    FSelectFields: Boolean;
    FOnlySelect: Boolean;
    function GetNewSheetName: string;
    function CheckSheetName(SheetName: string): Boolean;
    procedure SetSheetName(SheetName: string);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(Collection: TCollection); override;

  published
    { Published declarations }
    property SheetName: string read FSheetName write SetSheetName;
    property DataSet: TCustomAdoDataSet read FDataSet write FDataSet;
    property DBGrid: TDBGrid read FDBGrid write FDBGrid;
    property DxDBGrid: TDxDBGrid read FDxDBGrid write FDxDBGrid;
    //导出时用户可以选择字段
    property SelectFields: Boolean read FSelectFields write FSelectFields;
    //只导出选中记录
    property OnlySelect: Boolean read FOnlySelect write FOnlySelect;
  end;

  {TDataItems}
  TDataItems = class(TCollection)
  private
    { Private declarations }
    function GetItem(Index: Integer): TDataItem;
    procedure SetItem(Index: Integer; const Value: TDataItem);
  protected
    { Protected declarations }
  public
    { Public declarations }
    function Add: TDataItem;
    function FindItemID(ID: Integer): TDataItem;
    function Insert(Index: Integer): TDataItem;
    property Items[Index: Integer]: TDataItem read GetItem write SetItem;
  published
    { Published declarations }
  end;

  {TExcelWithOdbc}
  TExcelWithOdbc = class(TComponent)
  private
    { Private declarations }
    FAutoGetFileName: Boolean;
    FAutoOpen: Boolean;
    FExcelFileName: TFileName;
    FDataItems: TDataItems;
    FShowProgress: Boolean;
    FTitle: string;
    function GetFileName: string;
    procedure DataSetExport(OutDataSet: TCustomADODataSet; Con1: TADOConnection;
      SheetName: string; SelectFields: Boolean);
    procedure DBGridExport(OutGrid: TDBGrid; Con1: TADOConnection; SheetName:
      string; SelectFields, OnlySelect: Boolean);
    procedure DxGridExport(OutGrid: TDxDBGrid; Con1: TADOConnection; SheetName:
      string; SelectFields, OnlySelect: Boolean);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destory;
    procedure Execute;
  published
    { Published declarations }
    property AutoGetFileName: Boolean read FAutoGetFileName write
      FAutoGetFileName;
    property AutoOpen: Boolean read FAutoOpen write FAutoOpen;
    property ExcelFileName: TFileName read FExcelFileName write FExcelFileName;
    property DataItems: TDataItems read FDataItems write FDataItems;
    property Title: string read FTitle write FTitle;
    property ShowProgress: Boolean read FShowProgress write FShowProgress;
  end;
  TOutField = record
    FieldIndex: integer;
    FieldType: integer; //1、string;2、int;3、other;4、datetime
  end;

const
  E_Dsn: string =
  'DRIVER={Microsoft Excel Driver (*.xls)};DSN='''';FIRSTROWHASNAMES=1;READONLY=FALSE;CREATE_DB="%s";DBQ=%s';

implementation

uses SelectFieldsfrm, Progress;

{TDataItem}

constructor TDataItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FSheetName := GetNewSheetName;
end;

function TDataItem.GetNewSheetName: string;
var
  i: integer;
begin
  i := 1;
  repeat
    Result := 'SheetName' + inttostr(i);
    inc(i);
  until CheckSheetName(Result);
end;

function TDataItem.CheckSheetName(SheetName: string): Boolean;
var
  i: integer;
begin
  Result := True;
  for i := 0 to Collection.Count - 1 do
  begin
    if (i <> Index) and (TDataItem(Collection.Items[i]).FSheetName = SheetName)
      then
    begin
      Result := False;
      Exit;
    end;
  end;
end;

procedure TDataItem.SetSheetName(SheetName: string);
begin
  if (trim(SheetName) <> '') and CheckSheetName(SheetName) then
    FSheetName := SheetName;
end;

{TDataItems}

function TDataItems.Add: TDataItem;
begin
  Result := TDataItem(inherited Add);
end;

function TDataItems.FindItemID(ID: Integer): TDataItem;
begin
  Result := TDataItem(inherited FindItemID(ID));
end;

function TDataItems.Insert(Index: Integer): TDataItem;
begin
  Result := TDataItem(inherited Insert(Index));
end;

function TDataItems.GetItem(Index: Integer): TDataItem;
begin
  Result := TDataItem(inherited GetItem(Index));
end;

procedure TDataItems.SetItem(Index: Integer; const Value: TDataItem);
begin
  Items[Index].Assign(Value);
end;

{TExcelWithOdbc}

constructor TExcelWithOdbc.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataItems := TDataItems.Create(TDataItem);
end;

destructor TExcelWithOdbc.Destory;
begin
  FDataItems.Free;
  inherited;
end;

function TExcelWithOdbc.GetFileName: string;
var
  Save1: TSaveDialog;
begin
  Save1 := TSaveDialog.Create(Application);
  Save1.Filter := 'Microsoft Excel 工作表(*.xls)|*.xls';
  Save1.FileName := FExcelFileName;
  if FTitle <> '' then
    Save1.Title := FTitle;
  if FAutoGetFileName then
  begin
    if Save1.Execute then
      FExcelFileName := Save1.FileName
    else
      FExcelFileName := '';
  end;
  if (length(FExcelFileName) > 4) and (UpperCase(Copy(FExcelFileName,
    length(FExcelFileName) - 3, 4)) <> '.XLS') then
    FExcelFileName := FExcelFileName + '.xls';
  while FileExists(FExcelFileName) do
  begin
    case Application.MessageBox(PChar('文件' + FExcelfileName +
      '已经存在，是否覆盖？'), '提示', MB_YESNOCANCEL + MB_ICONWARNING) of
      IDYES:
        begin
          try
            DeleteFile(FExcelFileName);
          except
            Application.MessageBox('请重新指定文件名！', '出现错误',
              MB_ICONWARNING + MB_OK);
            if Save1.Execute then
              FExcelFileName := Save1.FileName
            else
              FExcelFileName := '';
          end;
        end;
      IDCANCEL: FExcelFileName := '';
      IDNO:
        begin
          if Save1.Execute then
            FExcelFileName := Save1.FileName
          else
            FExcelFileName := '';
        end;
    end;
  end;
  Save1.Free;
  Result := FExcelFileName;
end;

procedure TExcelWithOdbc.Execute;
var
  Con1: TADOConnection;
  i: integer;
begin
  if GetFileName = '' then
    Exit;
  Con1 := TADOConnection.Create(Application);
  Con1.ConnectionString := Format(E_Dsn, [FExcelFileName, FExcelFileName]);
  Con1.LoginPrompt := False;
  try
    Con1.Open;
  except
    on E: Exception do
    begin
      Application.MessageBox(PChar('出现错误！'#13#10 + E.Message), '提示',
        MB_ICONWARNING + MB_OK);
      Con1.Free;
      Exit;
    end;
  end;
  for i := 0 to FDataItems.Count - 1 do
  begin
    if FDataItems.Items[i].DataSet <> nil then
    begin
      if FDataItems.Items[i].DataSet.Active then
        DataSetExport(FDataItems.Items[i].DataSet, Con1,
          FDataItems.Items[i].SheetName, FDataItems.Items[i].SelectFields);
    end
    else if FDataItems.Items[i].DBGrid <> nil then
    begin
      if FDataItems.Items[i].DBGrid.DataSource.DataSet.Active then
        DBGridExport(FDataItems.Items[i].DBGrid, Con1,
          FDataItems.Items[i].SheetName, FDataItems.Items[i].SelectFields,
          FDataItems.Items[i].OnlySelect);
    end
    else if FDataItems.Items[i].DxDBGrid <> nil then
    begin
      if FDataItems.Items[i].DxDBGrid.DataSource.DataSet.Active then
        DxGridExport(FDataItems.Items[i].DxDBGrid, Con1,
          FDataItems.Items[i].SheetName, FDataItems.Items[i].SelectFields,
          FDataItems.Items[i].OnlySelect);
    end;
  end;
  Con1.Close;
  Con1.Free;
  if FAutoOpen and (Application.MessageBox('文件保存成功，是否打开？', '提示',
    MB_ICONINFORMATION + MB_YESNO) = IDYES) then
    ShellExecute(GetDesktopWindow, 'open', PChar(FExcelFileName), nil,
      PChar(ExtractFileDir(FExcelFileName)), SW_SHOWMAXIMIZED);
end;

//导出DataSet

procedure TExcelWithOdbc.DataSetExport(OutDataSet: TCustomADODataSet; Con1:
  TADOConnection; SheetName: string; SelectFields: Boolean);
var
  Qry1: TADOQuery;
  SqlStr, StringValue: string;
  i, j, SelectCount: integer;
  OutField: array of TOutField;
  Book1: Pointer;
begin
  OutDataSet.DisableControls;
  //保存标签
  Book1 := OutDataSet.GetBookmark;
  //创建查询
  Qry1 := TADOQuery.Create(Application);
  Qry1.Connection := Con1;
  //分析字段
  fmSelectFields := TfmSelectFields.Create(Application.MainForm);
  for i := 0 to OutDataSet.FieldCount - 1 do
  begin
    with fmSelectFields.ListView1.Items.Add do
    begin
      Caption := OutDataSet.Fields[i].DisplayName;
      SubItems.Add(inttostr(OutDataSet.Fields[i].Index));
      case OutDataSet.Fields[i].DataType of
        ftAutoInc, ftSmallint, ftInteger:
          begin
            SubItems.Add(inttostr(2));
            SubItems.Add('int');
          end;
        ftBCD, ftFloat:
          begin
            SubItems.Add(inttostr(2));
            SubItems.Add('numeric');
          end;
        ftDateTime, ftDate, ftTime:
          begin
            SubItems.Add(inttostr(4));
            SubItems.Add('datetime');
          end;
        ftString:
          begin
            SubItems.Add(inttostr(1));
            if OutDataSet.Fields[i].Size > 255 then
              SubItems.Add('memo')
            else
              SubItems.Add('varchar(255)');
          end;
        ftMemo, ftFmtMemo:
          begin
            SubItems.Add(inttostr(1));
            SubItems.Add('memo');
          end;
      else
        begin
          SubItems.Add(inttostr(3));
          SubItems.Add('varchar(255)');
        end;
      end;
      Checked := True;
    end;
  end;
  try
    SelectCount := 0;
    if SelectFields then
    begin
      if not (fmSelectFields.ShowModal = mrOK) then
        Exit;
      for i := 0 to fmSelectFields.ListView1.Items.Count - 1 do
      begin
        if fmSelectFields.ListView1.Items[i].Checked then
          SelectCount := SelectCount + 1;
      end;
    end;

    if FShowProgress then
      CreateProgress('输出“' + SheetName + '”到文件“' +
        ExtractFileName(FExcelFileName) + '”！', OutDataSet.RecordCount);
    //添加字段名
    SqlStr := 'CREATE TABLE [' + SheetName + '] (';
    if (not SelectFields) or (SelectCount = 0) or (SelectCount =
      fmSelectFields.ListView1.Items.Count) then
    begin
      SelectCount := fmSelectFields.ListView1.Items.Count;
      SetLength(OutField, SelectCount);
      for i := 0 to SelectCount - 1 do
      begin
        SqlStr := SqlStr + '[' + fmSelectFields.ListView1.Items[i].Caption + '] '
          + fmSelectFields.ListView1.Items[i].SubItems[2] + ', ';
        OutField[i].FieldIndex :=
          StrToInt(fmSelectFields.ListView1.Items[i].SubItems[0]);
        OutField[i].FieldType :=
          StrToInt(fmSelectFields.ListView1.Items[i].SubItems[1]);
      end;
    end
    else
    begin
      SetLength(OutField, SelectCount);
      j := 0;
      for i := 0 to fmSelectFields.ListView1.Items.Count - 1 do
      begin
        if fmSelectFields.ListView1.Items[i].Checked then
        begin
          SqlStr := SqlStr + '[' + fmSelectFields.ListView1.Items[i].Caption +
            '] ' + fmSelectFields.ListView1.Items[i].SubItems[2] + ', ';
          OutField[j].FieldIndex :=
            StrToInt(fmSelectFields.ListView1.Items[i].SubItems[0]);
          OutField[j].FieldType :=
            StrToInt(fmSelectFields.ListView1.Items[i].SubItems[1]);
          inc(j);
        end;
      end;
    end;
    Delete(SqlStr, length(SqlStr) - 1, 2);
    SqlStr := SqlStr + ')';
    //创建Sheet;
    Qry1.SQL.Text := SqlStr;
    Qry1.ExecSQL;

    //插入记录
    with OutDataSet do
    begin
      First;
      while not Eof do
      begin
        SqlStr := 'INSERT INTO [' + SheetName + '] values(';
        for i := 0 to SelectCount - 1 do
        begin
          if Fields[OutField[i].FieldIndex].IsNull then
          begin
            SqlStr := SqlStr + 'null,';
          end
          else
          begin
            case OutField[i].FieldType of
              1:
                begin
                  StringValue := Fields[OutField[i].FieldIndex].AsString;
                  StringValue := StringReplace(StringValue, ':', '：',
                    [rfReplaceAll]);
                  StringValue := StringReplace(StringValue, '''', '''''',
                    [rfReplaceAll]);
                  SqlStr := SqlStr + '''' + StringValue + ''',';
                end;
              2: SqlStr := SqlStr + Fields[OutField[i].FieldIndex].AsString +
                ',';
              3: SqlStr := SqlStr + '''' +
                Fields[OutField[i].FieldIndex].AsString + ''',';
              4: SqlStr := SqlStr +
                FloatToStr(Fields[OutField[i].FieldIndex].AsFloat) + ',';
            end;
          end;
        end;
        System.Delete(SqlStr, length(SqlStr), 1);
        SqlStr := SqlStr + ')';
        Qry1.SQL.Text := SqlStr;
        Qry1.ExecSQL;
        if FShowProgress then
          UpdateProgress(RecNo + 1);
        Next;
      end;
    end;
  finally
    fmSelectFields.Free;
    fmSelectFields := nil;
    Qry1.Free;
    OutDataSet.GotoBookmark(Book1);
    OutDataSet.EnableControls;
    if FShowProgress then
      DeleteProgress;
  end;
end;