Menampilkan Recordset ke Excel

'**************************************
' Name: ADODB RecordSet to Excel
' Description:This SubRoutine will Print
'     the Data in the Recordset to Excel, may
'     be it a SQL statement or valid Recordset
'     Table Name.
' By: krachit
'
' Inputs:The Recordset string & the Conn
'     ection String
'
' Returns:It will Print the Data from th
'     e Table to the Excel Along with the Head
'     ing & formating like Color, Borders, Aut
'     oSize & Bold Heading
'
' Assumes:A reference has to be set to A

'     DODB & Excel
'
'This code is copyrighted and has' limited warranties.Please see http://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=47409&lngWId=1'for details.'**************************************

'This Function Transfers Data from Recor
'     dset to the Excel

Private Sub Rec2Excel(xRecordSet As String, ConnectionString As String)

   'xRecordSet can b either SQL statement o
    '     r valid Recordset
    'ConnectionString is the String for Conn
    '     ecting the database
    Dim i As Integer
   Dim rs As ADODB.RecordSet
   Dim con As ADODB.Connection
   Dim exc As Excel.Application
   Set con = New ADODB.Connection
   Set rs = New ADODB.RecordSet
   con.Open ConnectionString
   rs.Open xRecordSet, con, adOpenStatic, adLockReadOnly
   Set exc = CreateObject("Excel.Application")
   exc.Workbooks.Add
   exc.Visible = True

   With exc


       For i = 0 To rs.Fields.Count - 1
           .Cells(1, i + 1) = rs(i).Name
       Next

       i = 1


       While Not rs.EOF
           i = i + 1


           For j = 0 To rs.Fields.Count - 1


               If rs(j).Type = adVarChar Then

                   If IsNull(rs(j)) Then
                       .Cells(i, j + 1) = ""
                   Else
                       .Cells(i, j + 1) = Trim(rs(j))
                   End If
                   .Cells(i, j + 1).Borders.LineStyle = xlDouble
                   .Cells(i, j + 1).Borders.Color = vbBlue
               ElseIf rs(j).Type = adDecimal Or rs(j).Type = adNumeric Then

                   If IsNull(rs(j)) Then
                       .Cells(i, j + 1) = ""
                   Else
                       .Cells(i, j + 1) = Str(rs(j))
                   End If
                   .Cells(i, j + 1).Borders.LineStyle = xlDouble
                   .Cells(i, j + 1).Borders.Color = vbBlue
               End If
           Next

           rs.MoveNext
       Wend

       .Range("A1:" & Chr(65 + j) & 1).Font.Bold = True
       .Range("A1:" & Chr(65 + j) & 1).Font.Color = vbRed
       .Range("A1:" & Chr(65 + j) & 1).Borders.LineStyle = xlDouble
       '.Range("A1:" & Chr(65 + j) & 1).Borders
        '     .Color = vbRed
        .Columns("$A:" & "$" & Chr(65 + j)).AutoFit
   End With
   Set rs = Nothing
   Set con = Nothing
End Sub