我要评论复制代码 代码如下:
'************************************************
'** 函数名称: 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
如您对本文有疑问或者有任何想说的，请点击进行留言回复，万千网友为您解惑！
网友评论