Option Compare Database
Option Explicit
Public Function funexport(strfilter As String, intfunctionid As Integer)
On Error GoTo Err_funErrorChecking
Dim strObjectName As String
Dim strFunctionName As String
Dim strselect As String
Dim rstdata As DAO.Recordset
Dim db As Database
Dim strPath As String
Dim objXL As Object
Dim objActiveWkb As Object
Dim objActiveWrksheet As Object
Dim intcolumn As Integer
Dim rstexport As DAO.Recordset
Set db = CurrentDb
Set rstdata = db.OpenRecordset("select * from usystbl000_export where functionid = " & intfunctionid)
strFunctionName = rstdata!Function
strObjectName = rstdata!ObjectName
Set rstdata = db.OpenRecordset("select * from usystbl000_exportdetail where functionid = " & intfunctionid)
rstdata.MoveFirst
Do Until rstdata.EOF
strselect = strselect & rstdata!FieldName & ", "
rstdata.MoveNext
Loop
strselect = Left(strselect, Len(strselect) - 2)
If strfilter = "" Then
Set rstexport = db.OpenRecordset("SELECT " & strselect & " FROM " & strObjectName)
Else
Set rstexport = db.OpenRecordset("SELECT " & strselect & " FROM " & strObjectName & " WHERE " & strfilter)
End If
If rstexport.RecordCount > 0 Then
'browse folder option to create filename
strPath = BrowseFolder("Please select a folder for EXPORT")
If strPath <> "Cancelled" Then
'open excel
Set objXL = CreateObject("Excel.Application")
objXL.Application.Workbooks.Add
objXL.Visible = False
Set objActiveWkb = objXL.Application.ActiveWorkbook
Set objActiveWrksheet = objActiveWkb.Worksheets("Sheet1")
objXL.ScreenUpdating = False
objXL.DisplayAlerts = False
'loop through header fields and create them
'Export details
With objActiveWrksheet
.Range("A1").CopyFromRecordset rstexport
rstdata.MoveFirst
intcolumn = 1
Do Until rstdata.EOF
.Columns(intcolumn).NumberFormat = rstdata!Format
.Columns(intcolumn).ColumnWidth = rstdata!ColumnWidth
'.Columns(intcolumn).HorizontalAlignment = rstdata!Alignment
intcolumn = intcolumn + 1
rstdata.MoveNext
Loop
End With
objActiveWkb.SaveAs strPath & "\" & strFunctionName & "_" & Format(Now, "YYYYMMDDhhmmss") & ".xlsx."
objActiveWkb.Close SaveChanges:=True
objXL.Application.Quit
Set objActiveWrksheet = Nothing: Set objActiveWkb = Nothing: Set objXL = Nothing
End If
End If
Exit_funErrorChecking:
Exit Function
Err_funErrorChecking:
Call funErrorChecking(Err.Description, Err.Number, Application.CurrentObjectName, "funexport")
Resume Exit_funErrorChecking
Resume
End Function