by Chris Beckingham (6 Submissions)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Tue 15th May 2001
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Export a recordset to Excel
VBcoders
Dim appExcel As Excel.Application
Dim wrkExcel As Excel.Workbook
Dim shtExcel As Excel.Worksheet
On Error Resume Next
Set appExcel = GetObject(, "Excel.Application")
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
If appExcel Is Nothing Then
MsgBox "Cannot Open Microsoft Excel For Export", vbCritical
Exit Sub
End If
End If
intNewSheets = appExcel.SheetsInNewWorkbook
appExcel.SheetsInNewWorkbook = 1
Set wrkExcel = appExcel.Workbooks.Add
appExcel.SheetsInNewWorkbook = intNewSheets
Set shtExcel = wrkExcel.Sheets(1)
With shtExcel
For intCount = 0 To rstReport.Fields.Count - 1
shtExcel.Cells(1, intCount + 1).Value = rstReport.Fields(intCount).Name
rstReport.MoveFirst
For intRow = 1 To rstReport.RecordCount
shtExcel.Cells(intRow + 1, intCount + 1).Value = rstReport.Fields(intCount).Value
rstReport.MoveNext
Next
Next
.Columns("A:" & Chr(64 + rstReport.Fields.Count)).Select
.Columns("A:" & Chr(64 + rstReport.Fields.Count)).EntireColumn.AutoFit
.Range("A1:" & Chr(64 + rstReport.Fields.Count) & "1").Select
End With
With appExcel.Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
shtExcel.Select
shtExcel.Name = lstReports.Text
shtExcel.Range("A1").Select
wrkExcel.Names.Add Name:="Print_Titles", RefersToR1C1:="=Sheet1!R1C1:R1C" & CStr(rstReport.Fields.Count)
With shtExcel.PageSetup
.PrintTitleRows = shtExcel.Rows(1).Address
.PrintTitleColumns = ""
End With
shtExcel.PageSetup.PrintArea = ""
With shtExcel.PageSetup
.LeftHeader = ""
.CenterHeader = strHeader
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
appExcel.DisplayFullScreen = True
appExcel.DisplayFullScreen = False
appExcel.Visible = True
Set shtExcel = Nothing
Set wrkExcel = Nothing
Set appExcel = Nothing
End Sub