代码如下:


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