将数据导出至 M$ Access-tutorial mysql-php.cn

Dev Express 中的 dxDBGrid/cxGrid 均提供了将表格中数据导出到 M$ Excel 等中的方法，但大多时候，却需将数据导出至 M$ Access 中...
    于是便有了本文。

    uses
      ComObj, Gauges, ShellAPI;

    const
      ExportTabName_MDB = '营销数据';
      MDBStr = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=%s';

    var
      ExportName: string;
      ExportColumnLst: TStringList; //列名;列类型(长度)
    begin
      ExportName:= '导出结果.MDB'; //use a SaveDialog to select the save name here
      ExportColumnLst:= TStringList.Create;

      //（示例）导出列列表，注意格式
      ExportColumnLst.Add('Contact;联系人 varchar(30)');
      ExportColumnLst.Add('Gender;性别 varchar(2)');
      ExportColumnLst.Add('Address;地址 varchar(100)');
      ExportColumnLst.Add('PostCode;邮编 varchar(6)');

      try
        ExportToMDB(ExportName, ExportColumnLst);
      finally
        FreeAndNil(ExportColumnLst);
      end;
    end;

    procedure ExportToMDB(ExportMDBName: string; ExportColumnLst);
      function CreateMDB(MDBFileName: string): Boolean;
      var
        vMDB: Variant;
      begin
        Result:= False;

        vMDB:= CreateOleObject('ADOX.Catalog');
        vMDB.Create(Format(MDBStr, [MDBFileName]));
        vMDB:= UnAssigned;

        Result:= True;
      end;

      function CreateTab(MDBAndTabName: string; ExportColumnLst: TStringList;
        aqy_ExecSQL: TADOQuery): Boolean;
      var
        i: Integer;
        StrTmp: string;
        SQLTxt: string;
        MDBName: string;
        TabName: string;
      begin
        Result:= False;

        SQLTxt:= '';
        for i:= 0 to ExportColumnLst.Count - 1 do
        begin
          StrTmp:= ExportColumnLst.Strings;

          if SQLTxt = '' then
            SQLTxt:= Copy(StrTmp, Pos(';', StrTmp) + 1, Length(StrTmp));
          else
            SQLTxt:= SQLTxt + ',' +
                       Copy(StrTmp, Pos(';', StrTmp) + 1, Length(StrTmp));
        end;

        MDBName:= Copy(MDBAndTabName, 1, Pos(';', MDBAndTabName) - 1);
        TabName:= Copy(
                       MDBAndTabName,
                       Pos(';', MDBAndTabName) + 1,
                       Length(MDBAndTabName)
                      );

        with aqy_ExecSQL do
        try
          Close;

          ConnectionString:=
            'Provider=MSDataShape.1;Data Provider=Microsoft.Jet.OLEDB.4.0;' +
            'Data Source=' + MDBName + ';Persist Security Info=false';

          SQL.Text:=
            'create table ' + TabName +
            '(' +
              SQLTxt +
            ')';

          try
            ExecSQL;
            Close;
          except
            on E: Exception do
            begin
              MessageBox(
                         Handle,
                         PChar('创建表失败！' + #13 + '失败原因：' + E.Message),
                         '错误',
                         MB_OK + MB_ICONERROR
                        );
              Close;
              Exit;
            end;
          end;
        finally
          //Free;
        end;

        Result:= True;
      end;
    var
      aqy_ExecSQL: TADOQuery;
      SQLTxt: string;
      i: Integer;
      StrTmp: string;
      ExportColumn: string;
      ExportColumnParam: string;
      ExportParamLst: TStringList;
      GgTip: TGauge;
      CurrRec: Integer;
    begin
      if CreateMDB(ExportMDBName) then
      begin
        aqy_ExecSQL:= TADOQuery.Create(Self);
        try
          if CreateTab(
                       ExportMDBName + ';' + ExportTabName_MDB,
                       ExportColumnLst,
                       aqy_ExecSQL
                      ) then
          begin
            Screen.Cursor:= crHourGlass;

            ExportColumn:= '';
            ExportColumnParam:= '';
            ExportParamLst:= TStringList.Create;
            for i:= 0 to ExportColumnLst.Count - 1 do
            begin
              StrTmp:= ExportColumnLst.Strings;

              if ExportColumn = '' then
              begin
                ExportColumn:= Copy(StrTmp, 1, Pos(';', StrTmp) - 1);
                ExportColumnParam:= ':' + ExportColumn;
                ExportParamLst.Add(ExportColumn);
              end
              else
              begin
                ExportColumn:= ExportColumn + ',' +
                                 Copy(StrTmp, 1, Pos(';', StrTmp) - 1);
                ExportColumnParam:= ExportColumnParam + ',:' +
                                      Copy(StrTmp, 1, Pos(';', StrTmp) - 1);
                ExportParamLst.Add(Copy(StrTmp, 1, Pos(';', StrTmp) - 1));
              end;
            end;

            SQLTxt:=
              'select ' + ExportColumn + ' from TabName where ID=' +
              aqy_Tmp1.FieldByName('ID').AsString;

            try
              with aqy_ExportData do //aqy_ExportData: TADOQuery;
              begin
                Close;
                SQL.Text:= SQLTxt;
                Open;

                //pnl_ExportFile: TPanel;
                GgTip:= TGauge.Create(pnl_ExportFile); //Gauge 进度提示
                with GgTip do
                begin
                  Parent:= pnl_ExportFile;
                  Left:= 0;
                  Height:= 21;
                  Width:= pnl_ExportFile.Width;
                  ForeColor:= clFuchsia;
                  MinValue:= 0;
                  MaxValue:= RecordCount;
                  Visible:= True;
                  Update;
                end;

                CurrRec:= 0;
                while not Eof do
                begin
                  Inc(CurrRec);

                  if CurrRec mod 20 = 0 then
                  begin
                    GgTip.Progress:= CurrRec;
                    Update;

                    Application.ProcessMessages;
                  end;

                  with aqy_ExecSQL do
                  begin
                    Close;

                    SQL.Text:=
                      'Insert Into ' + ExportTabName_MDB +
                      ' Values(' + ExportColumnParam + ')';

                    for i:= 0 to ExportParamLst.Count - 1 do
                      Parameters.ParamByName(ExportParamLst.Strings).Value:=
                       aqy_ExportData.FieldByName(
                                                  ExportParamLst.Strings
                                                 ).AsString;

                    try
                      ExecSQL;
                    except
                      on E: Exception do
                      begin
                        Close;
                        GgTip.Visible:= False;
                        Update;

                        MessageBox(
                                   Handle,
                                   PChar('导出文件失败！ ' + #13 + '失败原因：' +
                                         E.Message + ' '
                                        ),
                                   '错误',
                                   MB_OK + MB_ICONERROR
                                  );
                        Exit;
                      end;
                    end;
                  end; //End with

                  aqy_ExecSQL.Close;

                  Next;
                end; //End while

                Close; //aqy_ExportData
                GgTip.Visible:= False;

                if MessageBox(
                              Handle,
                              PChar('导出文件成功！ ' + #13 +
                                    '现在查看导出结果（' + ExportMDBName + '吗？'
                                   ),
                              '提示',
                               MB_YESNO + MB_ICONINFORMATION
                             ) = IDYES then
                begin
                  ShellExecute(0, 'Open', PChar(ExportMDBName), nil, nil, SW_SHOW);
                end;
              end;
            except
              on E: Exception do
              begin
                pnl_ExportFile.Caption:= '';
                GgTip.Visible:= False;
                Update;

                MessageBox(
                           Handle,
                           PChar('导出文件过程中发生错误！ ' + #13 +
                                 '错误描述：' + E.Message + ' '
                                ),
                           '导出失败',
                           MB_OK + MB_ICONERROR
                          );
              end;
            end;
          end;
        finally
          FreeAndNil(aqy_ExecSQL);
          FreeAndNil(ExportParamLst);
          FreeAndNil(GgTip);

          Screen.Cursor:= crDefault;
        end;
      end;
    end;

    OK，Done！

ADelphiCoder