Export Subform to Excel

[grgimpy]

I have a form with a bunch of combo boxes and a datasheet subform. When the form is loaded the subform displays all the records from a specific table. The user may then use the combo boxes to set any number of conditions that will filter the data in the subform and display records based on those conditions.

I use vba to change the subform's recordsource based on what conditions the user has selected in the form.

What I want to do is export the subform exactly how appears in the main form to Excel. Right now I have it set up so that it determines the recordsource of the subform, creates a query based on the recordsource, then uses the "DoCmd.OuputTo" approach to export it to Excel. The problem is the formatting is much different than the way it is displayed in the subform (labels, order, etc.).

Is there a way to directly export a subform to Excel so that is maintains any changes to the recordsource made from the main form? Here's the code I have so far for reference:

'Create Excel Application object
Dim objExcelApp As Excel.Application
    Set objExcelApp = CreateObject("Excel.Application")
'Create New Excel Workbook
'All data will be copied into
'this Workbook later
Dim objExcelWrkBk1 As Excel.Workbook
    Set objExcelWrkBk1 = objExcelApp.Workbooks.Add()
    objExcelApp.Visible = True

'Variables to be used to store
'names of files and forms
Dim strExcelFileName As String
Dim strQryName As String

'Now we must determine the username of
'the person that is logged into
'the computer in order to save the image
'to the correct "Desktop" address.
'This line of code calls the function above.
Dim strUser As String
    strUser = fWin2KUserName

'Set Filepath name (Desktop) for temporarily
'created Excel workbooks
Dim strFilePath As String
    strFilePath = "C:\Documents and Settings\" & strUser & "\Desktop\"

'Create query based on datasheet subform
Dim db As Database
Dim QryDef As QueryDef
    strQryName = "Production Log"
    Set db = CurrentDb()
'First delete query if it already exists.
'By setting the error routine to "Resume
'Next", if an error occurs when the code
'tries to delete a query that is not there
'then it will move on.
On Error Resume Next
    db.QueryDefs.Delete (strQryName)
On Error GoTo Err_Handler
'Create query
    Set QryDef = db.CreateQueryDef(strQryName, Me.SubForm.Form.RecordSource)
            
'Datasheet Table
    strExcelFileName = "Table.xls"
    
    DoCmd.OutputTo acOutputQuery, strQryName, _
        acFormatXLS, strFilePath & strExcelFileName, False, , False

'Delete query created earlier
    db.QueryDefs.Delete (strQryName)
    
'Create another Excel Workbook variable
'where data will be exported to and stored
'temporarily
Dim objExcelWrkBk2 As Excel.Workbook
    Set objExcelWrkBk2 = objExcelApp.Workbooks.Open(strFilePath & strExcelFileName)

'Copy data from Workbook2 into
'master workbook (Workbook1)
    objExcelWrkBk2.Sheets.Copy objExcelWrkBk1.Sheets(1)
'Close temp workbook
    objExcelWrkBk2.Close
'Zoom in
    objExcelApp.ActiveWindow.Zoom = 80
'Adjust columns of master Workbook
    objExcelApp.Cells.Columns.AutoFit
'Format Date Column
    objExcelApp.Columns("A:A").Select
    objExcelApp.Selection.NumberFormat = "[$-409]m/d/yy h:mm AM/PM;@"
'Highlight upper left box
    objExcelApp.Range("A1").Select
    
'Delete temp Workbook
    Kill (strFilePath & strExcelFileName)

 

[grgimpy]

i'm getting closer. the problem now is that i can't save the updated recordsource of my temporary form. i don't get any errors, but the copy of the form and i manipulate just keeps the original recordsource when it is closed instead of saving the new recordsource. if i keep the form open when i export, the formatting is horrible.

any suggestions would be greatly appreciated.

Private Sub cmdExportXLS_Click()
On Error GoTo Err_Handler

'Create Excel Application object
Dim objExcelApp As Excel.Application
    Set objExcelApp = CreateObject("Excel.Application")
'Create New Excel Workbook
'All data will be copied into
'this Workbook later
Dim objExcelWrkBk1 As Excel.Workbook
    Set objExcelWrkBk1 = objExcelApp.Workbooks.Add()
    objExcelApp.Visible = True

'Variables to be used to store
'names of files and forms
Dim strExcelFileName As String
Dim strQryName As String

'Now we must determine the username of
'the person that is logged into
'the computer in order to save the image
'to the correct "Desktop" address.
'This line of code calls the function above.
Dim strUser As String
    strUser = fWin2KUserName

'Set Filepath name (Desktop) for temporarily
'created Excel workbooks
Dim strFilePath As String
    strFilePath = "C:\Documents and Settings\" & strUser & "\Desktop\"

'Define variables equal to the subform's
'Record Source and Source Object.
'Also define name of temporarily created
'form that will be used to send data to Excel.
Dim db As Database
    Set db = CurrentDb
Dim strSource As String
    strSource = Me.SubForm.Form.RecordSource
Dim strSourceObject As String
    strSourceObject = Me.SubForm.SourceObject
Dim strTempFrm As String
    strTempFrm = "TempFrm"

'If "TempFrm" is still in database for any
'reason, close it and delete it.  If the form
'does not exist, then "Resume Next" forces code
'to move forward.
On Error Resume Next
    DoCmd.Close acForm, strTempFrm
    DoCmd.DeleteObject acForm, strTempFrm
On Error GoTo Err_Handler

'Make a copy of the datasheet subform
    DoCmd.CopyObject , strTempFrm, acForm, strSourceObject
'Open the form
    DoCmd.OpenForm strTempFrm, , , , , acWindowNormal
'Change the record source of the copied form
'to the current record source of the datasheet subform
    Forms![TempFrm].RecordSource = strSource
'Close the temporary form
    DoCmd.Close acForm, strTempFrm, acSaveYes
'Define name of temporary excel file
    strExcelFileName = "Table.xls"
'Export the data from the temporary form
'to the temporary Excel File
    DoCmd.OutputTo acOutputForm, strTempFrm, _
        acFormatXLS, strFilePath & strExcelFileName, False, , False
'Delete temporary form
    DoCmd.DeleteObject acForm, strTempFrm
    
'Create another Excel Workbook variable
'where data will be exported to and stored
'temporarily.
'This allows user to choose where they
'want to the save the excel file.
'The DoCmd.OutputTo code requires a destination
'in order to export the data.  This data
'is moved to the to Workbook1.
Dim objExcelWrkBk2 As Excel.Workbook
    Set objExcelWrkBk2 = objExcelApp.Workbooks.Open(strFilePath & strExcelFileName)

'Copy data from Workbook2 into
'master workbook (Workbook1)
    objExcelWrkBk2.Sheets.Copy objExcelWrkBk1.Sheets(1)
'Close temp workbook
    objExcelWrkBk2.Close
'Zoom in
    objExcelApp.ActiveWindow.Zoom = 80
'Adjust columns of master Workbook
    objExcelApp.Cells.Columns.AutoFit
'Format Date Column
    objExcelApp.Columns("C:C").Select
    objExcelApp.Selection.NumberFormat = "[$-409]m/d/yy h:mm AM/PM;@"
'Highlight upper left box
    objExcelApp.Range("A1").Select
    
'Delete temp Workbook
    Kill (strFilePath & strExcelFileName)

Exit_Handler:
    Exit Sub
Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Exit_Handler
End Sub

 

[grgimpy]

here's the solution for anyone that is interested. the form just needs to be opened in Design Mode in order for the Recordsource to be permanently changed. simple enough.

    DoCmd.OpenForm strTempFrm, acDesign, , , acFormEdit, acWindowNormal

 

[cubadew]

How are you applying changes to the recordsource? I was able to make your code work with my setup... but it is exporting the entire db not those I have narrowed it by my configurable sql filter.

I am currently using a sql that simply takes all my search items and compiles them into one string then applies that as the filter to the form. I was hoping that this method you designed would allow that filter to regulate the items exported. No luck though...

One problem I did have... it wants me to save the tmp form each time. is there a way to have it just save and not prompt? My users will be very confused by that. Also, will this even work with an .mde?

 

[PWise]

try this

Dim rst As Recordset
Dim rng As Excel.Range
Dim objExcelApp As Excel.Application
Set objExcelApp = CreateObject("Excel.Application")
Dim objExcelWrkBk1 As Excel.Workbook
Set objExcelWrkBk1 = objExcelApp.Workbooks.Add()
objExcelApp.Visible = True
Set rst = Me.subfrmname.Form.Recordset
Set rng = objExcelWrkBk1.Worksheets("Sheet1").Range("a1")
rng.CopyFromRecordset rst