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