Export a DAO Recordset to an Excel Spreadsheet

Version Compatibility: Visual Basic 5, Visual Basic 6

More information: Requires a reference to DAO and Microsoft Excel Object Library Version 9.0 (the one that ships with Excel 2000). Will also work with Excel 8.0 object library (Excel 97), except for some of the file formats specified. If you have Excel 97, change the to formats to match those in the 8.0 library or use the default values as parameters.

Instructions: Copy the declarations and code below and paste directly into your VB project.\

Sub SaveAsExcel(ByVal rs As DAO.Recordset, ByVal filename _
As String, Optional Ffmt As XlFileFormat = xlWorkbookNormal, _
Optional bHeaders As Boolean = True)
'***********************************************************
' Marko Hernandez
' Dec. 2, 2000
'
' Exports a Recordset data into a Microsoft Excel Sheet and
'then can save as new file
' with a given format such Lotus, Q-Pro, dBase, Text
'
' Arguments:
'
' rs : Recordset object (DAO) containing data.
' filename: Name of the file.
' Ffmt: File Format the default value is the
'MS-Excel current version.
' bHeaders: If true the name of the fields will be inserted
'in the first row of each column.
'

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

'Field object
Dim fd As Field

'Cell count, the cells we can use
Dim CellCnt As Integer

'File Extension Type
Dim Fet As String

Screen.MousePointer = vbHourglass
' Assign object references to the variables. Use
' Add methods to create new workbook and worksheet
' objects.
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add

'Get the field names
If bHeaders Then
CellCnt = 1
For Each fd In rs.Fields
Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(1, CellCnt).Value = fd.Name
xlSheet.Cells(1, CellCnt).Interior.ColorIndex = 33
xlSheet.Cells(1, CellCnt).Font.Bold = True
xlSheet.Cells(1, CellCnt).BorderAround xlContinuous
CellCnt = CellCnt + 1
End Select
Next
End If

'Rewind the rescordset
rs.MoveFirst
i = 2
Do While Not rs.EOF()
CellCnt = 1
For Each fd In rs.Fields
Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Cells(i, CellCnt).Value = _
rs.Fields(fd.Name).Value
'xlSheet.Columns().AutoFit
CellCnt = CellCnt + 1
End Select
Next
rs.MoveNext
i = i + 1
Loop

'Fit all columns
CellCnt = 1
For Each fd In rs.Fields

Select Case fd.Type
Case dbBinary, dbGUID, dbLongBinary, _
dbVarBinary
' This type of data can't export to excel
Case Else
xlSheet.Columns(CellCnt).AutoFit
CellCnt = CellCnt + 1
End Select
Next

'Get the file extension
Select Case Ffmt
Case xlSYLK
Fet = "slk"
Case xlWKS
Fet = "wks"
Case xlWK1, xlWK1ALL, xlWK1FMT
Fet = "wk1"
Case xlCSV, xlCSVMac, xlCSVdos, xlCSVWindows
Fet = "csv"
Case xlDBF2, xlDBF3, xlDBF4
Fet = "dbf"
Case xlWorkbookNormal, xlExcel2FarEast, xlExcel3, _
xlExcel4, xlExcel4Workbook, xlExcel5, xlExcel6, _
xlExcel7, xlExcel9795
Fet = "xls"
Case xlHTML
Fet = "htm"
Case xlTextMac, xlTextdos, xlTextWindows, xlUnicodeText, _
xlCurrentPlatformText
Fet = "txt"
Case xlTextPrinter
Fet = "prn"
Case Else
Fet = "dat"
End Select

' Save the Worksheet.
If InStr(1, filename, ".") = 0 Then filename = _
filename + "." + Fet
xlSheet.SaveAs filename, Ffmt

' Close the Workbook
xlBook.Close
' Close Microsoft Excel with the Quit method.
xlApp.Quit

' Release the objects.
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing

Screen.MousePointer = vbDefault
End Sub
''*******************SAMPLE USAGE BELOW***********************
'Private Sub Command1_Click()
' SaveAsExcel Data1.Recordset.Clone(), Text1.Text, _
' Combo1.ItemData(Combo1.ListIndex)
'End Sub



Private Sub Form_Load()
'
' Text1.Text = "C:\New File"
' Combo1.AddItem "Installed Excel Format"
' Combo1.ItemData(Combo1.NewIndex) = xlWorkbookNormal
' Combo1.AddItem "Comma Separated Text"
' Combo1.ItemData(Combo1.NewIndex) = xlCSV
' Combo1.AddItem "Excel 95/97"
' Combo1.ItemData(Combo1.NewIndex) = xlExcel9795
' Combo1.AddItem "Internet Format (HTML)"
' Combo1.ItemData(Combo1.NewIndex) = xlHtml
' Combo1.AddItem "MS-DOS Text"
' Combo1.ItemData(Combo1.NewIndex) = xlTextMSDOS
' Combo1.AddItem "Lotus 123 (WK1)"
' Combo1.ItemData(Combo1.NewIndex) = xlWK1
' Combo1.AddItem "Lotus 123 (WKS)"
' Combo1.ItemData(Combo1.NewIndex) = xlWKS
' Combo1.AddItem "Quattro Pro"
' Combo1.ItemData(Combo1.NewIndex) = xlWQ1
'
' Combo1.ListIndex = 0

End Sub