Dev Express 中的 dxDBGrid/cxGrid 均提供了将表格中 数据 导出 到 M$ Excel 等中的方法，但大多时候，却需将 数据 导出 至 M$ Access 中... 于是便有了本文。 uses ComObj, Gauges, ShellAPI; const ExportTabName_MDB = '营销 数据 '; MDBStr = 'Provider=

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