用vba实现将记录集输出到Excel模板

'************************************************ 
'** 函数名称:  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