代码如下:

'************************************************

'** 函数名称: exporttemplettoexcel

'** 函数功能: 将记录集输出到 excel 模板

'** 参数说明:

'** strexcelfile 要保存的 excel 文件

'** strsql 查询语句，就是要导出哪些内容

'** strsheetname 工作表名称

'** adoconn 已经打开的数据库连接

'** 函数返回:

'** boolean 类型

'** true 成功导出模板

'** false 失败

'** 参考实例:

'** call exporttemplettoexcel(c:\\text.xls,查询语句,工作表1,adoconn)

'************************************************

private function exporttemplettoexcel(byval strexcelfile as string, _

byval strsql as string, _

byval strsheetname as string, _

byval adoconn as object) as boolean

dim adort as object

dim lngrecordcount as long ' 记录数

dim intfieldcount as integer ' 字段数

dim strfields as string ' 所有字段名

dim i as integer

dim exlapplication as object ' excel 实例

dim exlbook as object ' excel 工作区

dim exlsheet as object ' excel 当前要操作的工作表

on error goto localerr

me.mousepointer = vbhourglass

'// 创建 ado 记录集对象

set adort = createobject(adodb.recordset)

with adort

.activeconnection = adoconn

.cursorlocation = 3 'aduseclient

.cursortype = 3 'adopenstatic

.locktype = 1 'adlockreadonly

.source = strsql

.open

if .eof and .bof then

exporttemplettoexcel = false

else

'// 取得记录总数，+ 1 是表示还有一行字段名名称信息

lngrecordcount = .recordcount + 1

intfieldcount = .fields.count - 1

for i = 0 to intfieldcount

'// 生成字段名信息（vbtab 在 excel 里表示每个单元格之间的间隔）

strfields = strfields & .fields(i).name & vbtab

next

'// 去掉最后一个 vbtab 制表符

strfields = left$(strfields, len(strfields) - len(vbtab))

'// 创建excel实例

set exlapplication = createobject(excel.application)

'// 增加一个工作区

set exlbook = exlapplication.workbooks.add

'// 设置当前工作区为第一个工作表（默认会有3个）

set exlsheet = exlbook.worksheets(1)

'// 将第一个工作表改成指定的名称

exlsheet.name = strsheetname

'// 清除“剪切板”

clipboard.clear

'// 将字段名称复制到“剪切板”

clipboard.settext strfields

'// 选中a1单元格

exlsheet.range(a1).select

'// 粘贴字段名称

exlsheet.paste

'// 从a2开始复制记录集

exlsheet.range(a2).copyfromrecordset adort

'// 增加一个命名范围，作用是在导入时所需的范围

exlapplication.names.add strsheetname, = & strsheetname & !$a$1:$ & _

ugetcolname(intfieldcount + 1) & $ & lngrecordcount

'// 保存 excel 文件

exlbook.saveas strexcelfile

'// 退出 excel 实例

exlapplication.quit

exporttemplettoexcel = true

end if

'adstateopen = 1

if .state = 1 then

.close

end if

end with

localerr:

'*********************************************

'** 释放所有对象

'*********************************************

set exlsheet = nothing

set exlbook = nothing

set exlapplication = nothing

set adort = nothing

'*********************************************

if err.number <> 0 then

err.clear

end if

me.mousepointer = vbdefault

end function

'// 取得列名

private function ugetcolname(byval intnum as integer) as string

dim strcolnames as string

dim strreturn as string

'// 通常字段数不会太多，所以到 26*3 目前已经够了。

strcolnames = a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z, & _

aa,ab,ac,ad,ae,af,ag,ah,ai,aj,ak,al,am,an,ao,ap,aq,ar,as,at,au,av,aw,ax,ay,az, & _

ba,bb,bc,bd,be,bf,bg,bh,bi,bj,bk,bl,bm,bn,bo,bp,bq,br,bs,bt,bu,bv,bw,bx,by,bz

strreturn = split(strcolnames, ,)(intnum - 1)

ugetcolname = strreturn

end function