Public Sub CreateSpreadsheetFromRS(rst As Recordset, ByRef strFileName As String, _
Optional strSheetname As String = "Sheet1", _
Optional strRangeStart As String = "A1", _
Optional blnAutofit As Boolean = False, _
Optional blnVisible As Boolean = False, _
Optional blnClose As Boolean = True)
'recordset exporteren naar specifieke sheet
Dim appExcel As Excel.Application
Dim wbExcel As Workbook
Dim wsExcel As Worksheet
Dim blnSheetFound As Boolean
On Error GoTo Err_CreateSpreadsheetFromRS
blnSheetFound = False
If Not rst.EOF Then
Set appExcel = New Excel.Application
If Not FileExists(strFileName) Then
'Create Spreadsheet
Set wbExcel = appExcel.Workbooks.add
Set wsExcel = wbExcel.Worksheets.add
wsExcel.Name = strSheetname
wbExcel.SaveAs strFileName
Else
Set wbExcel = appExcel.Workbooks.Open(strFileName)
For Each wsExcel In wbExcel.Worksheets
If wsExcel.Name = strSheetname Then
Set wsExcel = wbExcel.Worksheets(strSheetname)
blnSheetFound = True
Exit For
End If
Next wsExcel
If Not blnSheetFound Then 'Add sheetname
Set wsExcel = wbExcel.Worksheets.add
wsExcel.Name = strSheetname
wbExcel.Save
End If
End If
appExcel.Visible = True
appExcel.WindowState = xlMinimized
' appExcel.Visible = blnVisible
Else
MsgBox "No records found", vbInformation, gstrApplicationName
strFileName = ""
Exit Sub
End If
'Add headers
Dim intX As Integer
For intX = 0 To rst.Fields.Count - 1
wsExcel.Range(Eval("""" & strSheetname & "!" & Chr(65 + intX) & "1""")) = rst.Fields(intX).Name
Next intX
wsExcel.Range(strSheetname & "!A2").CopyFromRecordset rst
If blnAutofit Then
FormatSheet appExcel, wsExcel
' wsExcel.Columns.AutoFit
' wsExcel.Rows.AutoFit
End If
If blnClose Then
wbExcel.Close SaveChanges:=True
Set wbExcel = Nothing
Set appExcel = Nothing
End If
Set rst = Nothing
Exit_CreateSpreadsheetFromRS:
On Error GoTo 0
Exit Sub
Err_CreateSpreadsheetFromRS:
ErrorProc Err.Number, Err.Description, "modExport", "CreateSpreadsheetFromRS"
Resume Exit_CreateSpreadsheetFromRS
Resume ' for debugging purposes
End Sub
Private Sub FormatSheet(appExcel As Excel.Application, ws As Excel.Worksheet)
With ws
.Range("A1").Select
.Range(appExcel.Selection, appExcel.Selection.End(xlToRight)).Select
With appExcel.Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With appExcel.Selection.Interior
.ColorIndex = 36
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Range(appExcel.Selection, appExcel.Selection.End(xlDown)).Select
appExcel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
appExcel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With appExcel.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With appExcel.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With appExcel.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With appExcel.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With appExcel.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With appExcel.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
appExcel.Selection.EntireColumn.AutoFit
End With
End Sub
