Export Recordset to Ms. Excell


Berikut ini adalah koding program (Vb6) untuk export data dari Recordset ke Excell, data bisa berasal dari SQL Server atau Ms. Acess :

Anda perlu menambahkan Refrence Object Library nya Ms. Excell.

Public Sub Export2Excel(RsExcell As ADODB.Recordset, StrFileExcel As String, ColFormatText As String, ColFormatText2 As String)

On Error GoTo Err_Export2Excel
   ‘Deklarasi Variabel
   Dim xlApp    As Excel.Application
   Dim xlBook   As Excel.Workbook
   Dim xlSheet  As Excel.Worksheet
   Dim RsTemp   As ADODB.Recordset
   Dim intX     As Integer
   Dim intY     As Integer
   Set xlApp = New Excel.Application
   Set xlBook = xlApp.Workbooks.Add
   Set xlSheet = xlBook.Worksheets.Add
  
   xlSheet.Name = “Lensa”
   Set RsTemp = RsExcell

   ‘Export Recordset ke Ms. Excell
   ‘Write Header (Field / Column)
   For intY = 0 To RsTemp.Fields.Count – 1
        ‘Write data to cell
        xlSheet.Cells(intX + 1, intY + 1).Value = RsTemp.Fields(intY).Name
   Next intY
   
   
   ‘Write Data (Record Tabel)
   intX = intX + 1
   While Not RsTemp.EOF
      For intY = 0 To RsTemp.Fields.Count – 1
        ‘ Penyeleksian Field atau column yang akan diformat ke Text
        If RsTemp.Fields(intY).Name = ColFormatText Or RsTemp.Fields(intY).Name = ColFormatText2 Then
            ‘Format Cell ke Format Text “@”
            xlSheet.Cells(intX + 1, intY + 1).NumberFormat = “@”
            ‘Write data to cell
            xlSheet.Cells(intX + 1, intY + 1).Value = RsTemp.Fields(intY).Value
           
        Else
         xlSheet.Cells(intX + 1, intY + 1).Value = RsTemp.Fields(intY).Value
        End If
      Next intY
      RsTemp.MoveNext
      intX = intX + 1
   Wend
  
   ‘Simpan file
   xlBook.SaveAs (StrFileExcel)
   xlBook.Close (False)
  
   ‘Exit_Export2Excel
   Set xlApp = Nothing
   Set xlBook = Nothing
   Set xlSheet = Nothing
   Set xlSheet1 = Nothing
   Set RsTemp = Nothing
   Exit Sub

Err_Export2Excel:
   xlBook.Close
   Set xlApp = Nothing
   Set xlBook = Nothing
   Set xlSheet = Nothing
   Set xlSheet1 = Nothing
   Set RsTemp = Nothing
   Err.Raise Err.Description

End Sub

About alkahfi

Bekerja di bidang IT-MIS di sebuah perusahaan Optik di Medan, sebagai Software Enginer.

Posted on January 31, 2008, in Programming. Bookmark the permalink. Leave a comment.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: