Public Function ITASend2Excel(frm As Form, Optional strSheetName As String)
' frm is the name of the form you want to send to Excel
' strSheetName is the name of the sheet you want to name it to
'-------------------------------------------------------------------------------------------
' FIRST ADDED BY: LV
' DATE ADDED: Rel V1 26/7/13
' DESCRIPTION OF FUNCTION: Exports the Recordsetclone of the form currently active to Excel
' Creates a table containing the data displayed on the form (even if filtered) _
with the table field captions as column headings in the correct order (by tab; _
exports them to Excel
'-------------------------------------------------------------------------------------------
' AMENDED BY: ITA - LV
' DATE AMENDED:
' AMENDMENTS MADE:
'-------------------------------------------------------------------------------------------
' NOTES: You should make sure the frm is a valid form (has a recordsource, is not dirty, _
is the correct subform etc...) _
Make sure you have Captions set in the underlying tables - if you want nice user _
friendly column headings. _
This function uses the recordsetclone which means the data exported will _
match that display even if the recordsource has been filtered using the filter mso on the ribbon. _
See step 2: it relies on the WHERE and FROM SQL statements which you may use in a forms recordsoutrce to _
in order to picl out the base query or table. _
!!!If you are using a complex SQL statement for the recordsource TEST this feature picks out the _
core query/table.
'-------------------------------------------------------------------------------------------
Dim rstCorrectColumns As DAO.Recordset
Dim rstcorrectheaders As DAO.Recordset
Dim rstFormDisplay As DAO.Recordset
Dim rstExport As DAO.Recordset
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim tdf As TableDef
Dim prop As DAO.Property
Dim fld As DAO.Field
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Dim ctl As control
Dim strSQL As String
Dim strRecordSource As String
Dim strFieldsToExport As String
Dim strFormRecordSource As String
Dim strFirstPart As String
Dim strTableOrQueryName As String
Dim i As Long
Dim i2 As Long
Dim intTabNo As Integer
On Error GoTo ITAError
Set dbs = CurrentDb
'****************************************************************************
'1. Get a list of the field names/columns required and in the correct order
'Prevent fields form being exported by using the tag "Hidden"
'****************************************************************************
Dim strFieldList As String
strFieldList = ""
'Debug.Print frm.RecordSource
intTabNo = -1
Do Until intTabNo = frm.Section(acDetail).Controls.Count 'just look in one section- at a time - _
otherwise tab numbers are duplicated (probably)
'Debug.Print intTabNo
intTabNo = intTabNo + 1
For Each ctl In frm.Section(acDetail).Controls
If ctl.ControlType = acComboBox Or ctl.ControlType = acTextBox Or ctl.ControlType = acCheckBox Then
If ctl.TabIndex = intTabNo Then
'Debug.Print ctl.Name
If Not InStr(1, ctl.Tag, "Hidden") > 0 Then
'Debug.Print ctl.Name
'Debug.Print ctl.TabIndex
If Len(strFieldList) = 0 Then
strFieldList = "SELECT " & ctl.ControlSource & ", "
'Debug.Print strSQL
Else
strFieldList = strFieldList & ctl.ControlSource & ", "
'Debug.Print strFieldList
End If
End If
Exit For
End If
End If
Next
Loop
strFieldList = Left(strFieldList, Len(strFieldList) - 2)
'Debug.Print "field list " & strFieldList
'****************************************************************************
'2. Get the qry or tbl recordsource name
'****************************************************************************
strFormRecordSource = frm.RecordSource
'If the recordsource has been altered (e.g. by selecting from combos or whatever and looks something like this: _
SELECT qryfrmTasksProject.* FROM qryfrmTasksProject WHERE ([TSK_Project_ID] = 3)
If InStr(1, strFormRecordSource, "FROM") > 0 Then 'the record source is not just the query or table name _
(it is further filtered - but in recordsource not filter property)
'Strip out up until the start of the query/table name - assume "FROM"
Dim lngFromPosition As Long
lngFromPosition = InStr(1, strFormRecordSource, "FROM")
strFirstPart = Mid(strFormRecordSource, lngFromPosition + 5) ' + 6 takes off the following " FROM "
'Debug.Print "strFirstPart " & strFirstPart
'Strip out from after the query/table name - assume " WHERE"
lngFromPosition = InStr(1, strFirstPart, " WHERE")
strTableOrQueryName = Left(strFirstPart, lngFromPosition - 1)
'Debug.Print strTableOrQueryName
Else: strTableOrQueryName = frm.RecordSource
End If
''****************************************************************************
'3. Create a query with the correct headings. _
The base recordsource will use these.
''****************************************************************************
strFieldsToExport = strFieldList & " FROM " & strTableOrQueryName
'Debug.Print strFieldsToExport
'****************************************************************************
'4. If it's already there delete the local table to be used to store the export data
'****************************************************************************
If CheckIfTableExists("tblLocalExportExcel") = True Then
DoCmd.DeleteObject acTable, "tblLocalExportExcel"
End If
'
'****************************************************************************
'5. Create the table and empty it - it has the right columns but the the wrong number of records
'****************************************************************************
strSQL = strFieldList & " INTO tblLocalExportExcel" & " FROM " & strTableOrQueryName
'Debug.Print strSQL
DBEngine(0)(0).Execute strSQL, dbFailOnError
'empty the table - it has the unfiltered data it
strSQL = "DELETE *.* FROM tblLocalExportExcel"
DBEngine(0)(0).Execute strSQL, dbFailOnError
'****************************************************************************
'6. Add the data displayed on the form to the empty local table
'****************************************************************************
Set rstCorrectColumns = dbs.OpenRecordset("tblLocalExportExcel", dbOpenDynaset) 'correct columns but not headings
Set rstFormDisplay = frm.RecordsetClone
With rstCorrectColumns
'fill with reoords from the rstFormDisplay
rstFormDisplay.MoveLast
If Not (rstFormDisplay.BOF And rstFormDisplay.EOF) Then
rstFormDisplay.MoveFirst
Do While Not rstFormDisplay.EOF
.AddNew
For i = 0 To .Fields.Count - 1
For i2 = 0 To rstFormDisplay.Fields.Count - 1
If .Fields(i).Name = rstFormDisplay.Fields(i2).Name Then
.Fields(.Fields(i).Name) = rstFormDisplay(rstFormDisplay.Fields(i2).Name)
Exit For
End If
Next
Next
.Update
rstFormDisplay.MoveNext
Loop
End If
.Close
End With
'****************************************************************************
'6. Rename the table column headings (captions) to the required captions - _
use the query created in step 3.
'****************************************************************************
Set tdf = dbs.TableDefs("tblLocalExportExcel")
'Re-initialised counter
i2 = 0
Set rstcorrectheaders = dbs.OpenRecordset(strTableOrQueryName) ' this has the correct headers in
With rstcorrectheaders
For Each fld In tdf.Fields
For i2 = 0 To .Fields.Count - 1
If fld.Name = .Fields(i2).Name Then
'Debug.Print .Fields(i2).Name
On Error Resume Next 'Ignore error if the recordsource field does not have a caption _
the field name will be used instead
fld.Name = .Fields(i2).Properties("Caption")
If DBEngine.Errors(0).Number = 3270 Then
'ignore
Else: Resume ITAError
End If
On Error GoTo ITAError
Exit For
End If
Next
Next
.Close
End With
Set rstcorrectheaders = Nothing
Set rstExport = dbs.OpenRecordset("tblLocalExportExcel")
'***************************************************************************
'Create the spreadsheet
'****************************************************************************
Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Add
ApXL.visible = True
Set xlWSh = xlWBk.Worksheets("Sheet1")
If Len(strSheetName) > 0 Then
xlWSh.Name = Left(strSheetName, 34)
End If
xlWSh.Range("A1").Select 'Columns
'***************************************************************************
'Set the column headings to the table field names
'****************************************************************************
For Each fld In rstExport.Fields
ApXL.activecell = fld.Name
ApXL.activecell.Offset(0, 1).Select
Next
'***************************************************************************
'Copy the data from the Recordset to the spreadsheet
'****************************************************************************
rstExport.MoveFirst
xlWSh.Range("A2").CopyFromRecordset rstExport ' Range is start of data - i.e. excluding headers
xlWSh.Range("1:1").Select ' Used to select the header
' This is included to show some of what you can do about formatting.
' You can comment out or delete any of this below that you don't want to
' use in your own export.
With ApXL.Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
ApXL.Selection.Font.Bold = True
With ApXL.Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
' selects all of the cells
ApXL.ActiveSheet.Cells.Select
' does the "autofit" for all columns
ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
rstExport.Close
Set rstExport = Nothing
ITAExit:
Exit Function
ITAError:
ITATrapErrors Err.Number, Err.Description
Resume ITAExit
End Function
