Dim objExcelApp As Excel.Application
Dim xlsExcelSheet As Excel.Worksheet
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim col As Integer
Dim row As Integer
Dim strAccessDB As String
Dim FC As Integer
Private Sub Command0_Click()
exportToExcel "C:\Development\AccessDB\Scratchpad.mdb", _
"tblMemoOutput"
End Sub
Private Function exportToExcel(ByVal dbLocation As String, _
ByVal tblName As String) As Boolean
'Setup error handling
On Error GoTo exportToExcel_Err
exportToExcel = False
' Create the Excel application.
Set objExcelApp = New Excel.Application
objExcelApp.Visible = True
' Add the Excel spreadsheet.
objExcelApp.Workbooks.Add
' Check for later versions.
If Val(objExcelApp.Application.Version) >= 8 Then
Set xlsExcelSheet = objExcelApp.Worksheets(1)
Else
Set xlsExcelSheet = objExcelApp
End If
' Open the Access database.
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & dbLocation & ";" & _
"Persist Security Info=False"
conn.Open
' Select the data.
Set rs = conn.Execute(tblName, , _
adCmdTableDirect)
' Make the column headers.
FC = rs.Fields.Count - 1
For col = 0 To FC
xlsExcelSheet.Cells(1, col + 1) = rs.Fields(col).Name
Next col
' Get data from the database and insert
' it into the spreadsheet.
row = 2
Do While Not rs.EOF
For col = 0 To FC
xlsExcelSheet.Cells(row, col + 1) = rs.Fields(col).Value
Next col
row = row + 1
rs.MoveNext
Loop
'All is well
exportToExcel = True
exportToExcel_Exit:
'Cleanup code
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
Set objExcelApp = Nothing
Exit Function
exportToExcel_Err:
exportToExcel = False
'Alert the user that an error occurred
MsgBox Err.Number & vbCrLf & Err.Description
Resume exportToExcel_Exit
End Function
