Public Function fncExportFormRecords _
(ByVal strExportTo As String, _
ByVal Frm As Form, _
ByVal strFilename As String _
) As Boolean
' arnelgp
'_______________________________________
' strExportTo either "Excel" or "Text"
' Frm the form you need to Export to Excel or Text file
' strFileName the Excel/Text filename to create
'
On Error GoTo fncExportFormRecordsToExcel_Error
'arnelgp
Const TEST_QUERY As String = "zzQuery"
Dim strSql As String
Dim strSelect As String
Dim strWhere As String
Dim strWhereAdd As String
Dim strOrderBy As String
Dim strGROUPBY As String
Dim strHAVING As String
Dim db As DAO.Database
Dim qd As DAO.QueryDef
' get the SQL from the form
strSql = Frm.RecordSource
If Left(strSql, 7) <> "SELECT " Then
strSql = "SELECT * FROM " & strSql
End If
strSql = Replace(strSql, ";", "")
' get the filter of form
If Frm.FilterOn = True Then
strWhereAdd = Trim(RemoveFormReference(Frm.Filter))
End If
' parse the SQL
Call ParseSQL(strSql, _
strSelect, _
strWhere, _
strOrderBy, _
strGROUPBY, _
strHAVING)
If Len(strWhere) > 0 Then
strWhere = " " & Trim(strWhere)
End If
If Len(strWhereAdd) > 0 Then
If Len(strWhere) > 0 Then
strWhere = strWhere & " AND " & strWhereAdd
Else
strWhere = " WHERE " & strWhereAdd
End If
End If
'assemble again the SQL
strSql = strSelect & strWhere & strOrderBy & strGROUPBY & strHAVING
Set db = CurrentDb
'use the temporary query if it exists
On Error Resume Next
Set qd = db.QueryDefs(TEST_QUERY)
If Err.Number <> 0 Then
Set qd = db.CreateQueryDef(TEST_QUERY, strSql)
End If
qd.SQL = strSql
Set qd = Nothing
db.QueryDefs.Refresh
Set db = Nothing
Application.RefreshDatabaseWindow
On Error GoTo fncExportFormRecordsToExcel_Error
Select Case strExportTo
Case "Excel"
'export to excel
DoCmd.TransferSpreadsheet _
TransferType:=acExport, _
TableName:=TEST_QUERY, _
filename:=strFilename, _
HasFieldNames:=True
Do Until Len(Dir(strFilename)) > 0
DoEvents
Loop
Do Until VBA.FileLen(strFilename) > 0
DoEvents
Loop
' rename the sheet on the workbook
Dim oExcel As Object 'Excel.Application
Dim oWB As Object 'Excel.Workbook
Dim oSH As Object 'Excel.Worksheet
Dim i As Integer
Set oExcel = CreateObject("Excel.Application")
Set oWB = oExcel.Workbooks.Open(strFilename)
For Each oSH In oWB.Worksheets
If oSH.NAME Like "Export*" Then
i = i + 1
End If
Next
For Each oSH In oWB.Worksheets
If oSH.NAME = TEST_QUERY Then
oSH.NAME = "Export" & IIf(i > 0, "(" & i & ")", "")
Exit For
End If
Next
oWB.Save
Set oSH = Nothing
Set oWB = Nothing
oExcel.Quit
Set oExcel = Nothing
Case "Text"
DoCmd.TransferText _
TransferType:=acExportDelim, _
TableName:=TEST_QUERY, _
filename:=strFilename, _
HasFieldNames:=True
End Select
On Error GoTo 0
If Frm.FilterOn Then
MsgBox "Filtered records exported to " & strFilename & ".", vbInformation
Else
MsgBox "Records exported to " & strFilename & ".", vbInformation
End If
fncExportFormRecords = True
Exit Function
fncExportFormRecordsToExcel_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fncExportFormRecordsToExcel, line " & Erl & "."
End Functiongot compile error in this line :
Public Function RemoveFormReference(SQLCode As String) As String
' The purpose of this function is to take an SQL statement and convert
' a reference to a form control into a literal value
'For example, in SQL code, we need to change this:
'WHERE (((tblAmounts.intType) = [Forms]![frmTypeSelector]![cmbType]))
'OR this:
'WHERE (((tblAmounts.intType) = Forms!frmTypeSelector!cmbType))
'...to this, if the value is a number:
'WHERE (((tblAmounts.intType) = 1))
'...or this, if the value is a string:
'WHERE (((tblAmounts.strName)='Dennis'))
'...or this, if the value is a Date:
'WHERE (((tblAmounts.DateField)=#10/1/2015#))
Dim intFormRefPos As Integer, strFormName As String, strCtlName As String
Dim strTemp As String
' If no form references are found, just return the string argument
' If a form reference IS found, manipulate the string argument first, then return it
' Find the first type of form reference (see examples above)
intFormRefPos = InStr(1, SQLCode, "[Forms]![")
If intFormRefPos > 0 Then
' Extract the form name and control name from the SQL code
strFormName = Mid(SQLCode, intFormRefPos + 9)
strFormName = Left(strFormName, InStr(1, strFormName, "]") - 1)
strCtlName = Mid(SQLCode, intFormRefPos + 9 + Len(strFormName) + 3)
strCtlName = Left(strCtlName, InStr(1, strCtlName, "]") - 1)
' Insert the literal value in the place of the control reference
strTemp = Left(SQLCode, intFormRefPos - 1)
If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
If IsDate(Forms(strFormName).Controls(strCtlName)) Then
strTemp = strTemp & "#"
Else
strTemp = strTemp & "'"
End If
End If
strTemp = strTemp & Forms(strFormName).Controls(strCtlName)
If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
If IsDate(Forms(strFormName).Controls(strCtlName)) Then
strTemp = strTemp & "#"
Else
strTemp = strTemp & "'"
End If
End If
strTemp = strTemp & Mid(SQLCode, intFormRefPos + 9 + Len(strFormName) + 3 + Len(strCtlName) + 1)
SQLCode = strTemp
Else
' Find the second type of form reference (see examples above)
intFormRefPos = InStr(1, SQLCode, "Forms!")
If intFormRefPos > 0 Then
' Extract the form name and control name from the SQL code
strFormName = Mid(SQLCode, intFormRefPos + 6)
strFormName = Left(strFormName, InStr(1, strFormName, "!") - 1)
strCtlName = Mid(SQLCode, intFormRefPos + 6 + Len(strFormName) + 1)
strCtlName = Left(strCtlName, InStr(1, strCtlName, ")") - 1)
' Insert the literal value in the place of the control reference
strTemp = Left(SQLCode, intFormRefPos - 1)
If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
If IsDate(Forms(strFormName).Controls(strCtlName)) Then
strTemp = strTemp & "#"
Else
strTemp = strTemp & "'"
End If
End If
strTemp = strTemp & Forms(strFormName).Controls(strCtlName)
If IsNumeric(Forms(strFormName).Controls(strCtlName)) = False Then
If IsDate(Forms(strFormName).Controls(strCtlName)) Then
strTemp = strTemp & "#"
Else
strTemp = strTemp & "'"
End If
End If
strTemp = strTemp & Mid(SQLCode, intFormRefPos + 6 + Len(strFormName) + 1 + Len(strCtlName))
SQLCode = strTemp
End If
End If
RemoveFormReference = SQLCode
End Function
