기록 집합 을 엑셀 템 플 릿 에 vba 로 출력 합 니 다.


'************************************************ 
'**  :  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 

좋은 웹페이지 즐겨찾기