memindahkan database access ke excel

Materi kali ini penulis akan mengajak vbthok mania untuk membuat program yang bisa memindahkan isi database akses kedalam excel, mungkin ada diantara vbthok mania yang ingin membuat laporan dalam format excel dan datanya diambil dari database akses.Nah semoga artikel ini bermanfaat.
Oke kalau begitu buat form dan desain seperti contoh berikut

komponen yang dibutuhkan :
microsoft DAO 3.51 object library
microsoft excel 10.0 object library
microsoft common dialog control 6.0

untuk scrip codenya sebagai berikut :

Option Explicit
Dim dbSR As Database
Dim rs As Recordset
Dim strcaption, sn
Dim Td As TableDef
Dim i As Single
Dim Recs As Integer, Counter As Integer
Dim Barstring As String, MdbFile As String
Dim Junk As String

Private Type ExlCell
row As Long
col As Long
End Type

Private Sub Command2_Click()
Picture1.ForeColor = RGB(0, 0, 255)
On Error GoTo errhandler
CommonDialog1.Filter = "Access Files (*.mdb)"
CommonDialog1.FilterIndex = 0
CommonDialog1.FileName = "*.mdb"
CommonDialog1.ShowOpen
MdbFile = (CommonDialog1.FileName)

'set mdb file
Set dbSR = OpenDatabase(MdbFile)

List1.Clear
For Each Td In dbSR.TableDefs
Junk = Td.Name
Junk = UCase(Junk)
If Left(Junk, 4) <> "MSYS" Then
List1.AddItem Td.Name
End If
Next
Frame1.Visible = True

Exit Sub
errhandler:
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
dbSR.Close
Set dbSR = Nothing
End
End Sub


Private Sub List1_Click()
On Error GoTo errortrapper
Screen.MousePointer = vbHourglass

Junk = List1.Text
Set rs = dbSR.OpenRecordset(Junk, dbOpenDynaset)
Call ToExcel(rs, "C:\wk.xls")
GoTo skiperrortrapper
errortrapper:
Beep
Screen.MousePointer = vbDefault
MsgBox "This is a system file" & Chr(10) & "and is not accessible."
skiperrortrapper:
Screen.MousePointer = vbDefault
End Sub

Private Sub CopyRecords(rs As Recordset, ws As Worksheet, _
StartingCell As ExlCell)
Dim SomeArray() As Variant
Dim row As Long, col As Long
Dim fd As Field
If rs.EOF And rs.BOF Then Exit Sub
rs.MoveLast
ReDim SomeArray(rs.RecordCount + 1, rs.Fields.Count)
col = 0

For Each fd In rs.Fields
SomeArray(0, col) = fd.Name
col = col + 1
Next
rs.MoveFirst
Recs = rs.RecordCount
Counter = 0

For row = 1 To rs.RecordCount - 1
Counter = Counter + 1
If Counter <= Recs Then i = (Counter / Recs) * 100
UpdateProgress Picture1, i
For col = 0 To rs.Fields.Count - 1
SomeArray(row, col) = rs.Fields(col).Value
If IsNull(SomeArray(row, col)) Then _
SomeArray(row, col) = ""
Next
rs.MoveNext
Next
ws.Range(ws.Cells(StartingCell.row, StartingCell.col), _
ws.Cells(StartingCell.row + rs.RecordCount + 1, _
StartingCell.col + rs.Fields.Count)).Value = SomeArray
End Sub

Private Sub ToExcel(sn As Recordset, strcaption As String)
Dim oExcel As Object
Dim objExlSht As Object ' OLE automation object
Dim stCell As ExlCell

DoEvents
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If Err = 429 Then
Err = 0
Set oExcel = CreateObject("Excel.Application")
If Err = 429 Then
MsgBox Err & ": " & Error, vbExclamation + vbOKOnly
Exit Sub
End If
End If
oExcel.Workbooks.Add
oExcel.Worksheets("sheet1").Name = strcaption
Set objExlSht = oExcel.ActiveWorkbook.Sheets(1)
stCell.row = 1
stCell.col = 1
CopyRecords sn, objExlSht, stCell
oExcel.Visible = True
oExcel.Interactive = True
Set objExlSht = Nothing
Set oExcel = Nothing
Set sn = Nothing
End Sub

Sub UpdateProgress(PB As Control, ByVal percent)
Dim num$
If Not PB.AutoRedraw Then
PB.AutoRedraw = -1
End If
PB.Cls
PB.ScaleWidth = 100
PB.DrawMode = 10
num$ = Barstring & Format$(percent, "###") + "%"
PB.CurrentX = 50 - PB.TextWidth(num$) / 2
PB.CurrentY = (PB.ScaleHeight - PB.TextHeight(num$)) / 2
PB.Print num$
PB.Line (0, 0)-(percent, PB.ScaleHeight), , BF
PB.Refresh
End Sub

Untuk source codenya silakan donlot disini