Link to home
Start Free TrialLog in
Avatar of altiplano
altiplano

asked on

How to export Me.Recordset to Excel

I have a form with a subform in data view (Access 2002). The user can apply filters on the subform to get a subset of the data. Now I would like to allow the user to export this subset to Excel.

I know how to export a table to Excel, but how do I export me.record to Excel (or to a temporary table)? I guess I could iterate through the records and export them one by one to Excel, but I'm looking for a more efficient and mor generic solution.

Thanks,
Michiel
Avatar of PapaLorax
PapaLorax

Create a report with the fields
Bind the report at runtime to the recordset
Then on the output action use:

          DoCmd.OutputTo acOutputReport, "REPORT NAMEl", acFormatXLS, ,True



On Error Resume Next
Dim tdf As DAO.TableDef
Dim strSQL As String
DoCmd.DeleteObject acTable, "TempTbl"
Set tdf = CurrentDb.CreateTableDef("TempTbl", Me.RecordsetClone)
DoCmd.OutputTo acTable, "TempTbl", "MicrosoftExcel(*.xls)", "c:\temp\test.xls", True, ""
On Error Resume Next
Dim tdf As DAO.TableDef
DoCmd.DeleteObject acTable, "TempTbl"
Set tdf = CurrentDb.CreateTableDef("TempTbl", Me.RecordsetClone)
DoCmd.OutputTo acTable, "TempTbl", "MicrosoftExcel(*.xls)", "c:\temp\test.xls", True, ""

Sorry to be repetative...I had a redundant Dim statement.
J
Avatar of altiplano

ASKER

thanks for replying.

PapaLorax: Your solution would probably work, but is a nightmare to maintain. I need the same feature on several forms, so I would have to create and maintain a different report for each form.

jeffwilley:  This looks like what I trying to achieve, but it does not work. The TempTbl is not created. Is there something missing?

thanks,
Michiel
OK, I wrote a reasonably generic routine. For anyone who is interested:

Add the following two procedures to a module and call it as follows:

call ExportWysiwis(Me.Recordset, "My Excel sheet")

'---------------------------------------------------------------------------------------
' Procedure : ExportWysiwyg
' Purpose   : Export me.recordset ot Excel
'---------------------------------------------------------------------------------------
'
Public Function ExportWysiwyg(l_Source As String, l_FN As String)
On Error GoTo ExportWysiwyg_Error
Const ProcName = "ExportWysiwyg"
Dim l_MeRS          As DAO.Recordset
Dim l_TmpName       As String
Dim l_TmpTable      As DAO.Recordset
Dim l_Field         As DAO.Field
Dim l_FD            As New cls_FileDialog
   
    ' Get a unique name for the temporary table and create the table
    Do: l_TmpName = "tmp_wysiwig" & CStr(Int((99999 * Rnd))): Loop While TableExists(l_TmpName)
    DoCmd.TransferDatabase acImport, "Microsoft Access", CurrentDb.name, acTable, l_Source, l_TmpName, True
    Set l_TmpTable = CurrentDb.OpenRecordset(l_TmpName, dbOpenDynaset)

    ' Copy all records from Me.Recordset to the temporary table
    Set l_MeRS = Me.RecordsetClone
    Do While Not l_MeRS.EOF
        l_TmpTable.AddNew
        For Each l_Field In l_MeRS.Fields
            l_TmpTable.Fields(l_Field.name).Value = l_Field.Value
        Next
        l_TmpTable.Update
        l_MeRS.MoveNext
    Loop

    ' Open a file-selector window
    With l_FD
       .DefaultFileName = l_FN
       .DefaultExt = "xls"
       .Filter1Text = "Excel document"
       .Filter1Suffix = "*.xls"
       .ShowSave
    End With
       
    ' Export the data to an Excel file
    If Len(l_FD.FileName) > 0 Then DoCmd.TransferSpreadsheet acExport, , l_TmpName, l_FD.FileName

    ' Clean up
    l_MeRS.Close
    l_TmpTable.Close
    Set l_MeRS = Nothing
    Set l_TmpTable = Nothing
    CurrentDb.TableDefs.Delete l_TmpName

CleanExit:
    On Error GoTo 0
    Exit Function
ExportWysiwyg_Error:
    MsgBox Err.Description
    SysLog ModName, ProcName, Err.Number, Err.Description
    Resume CleanExit
End Function

'---------------------------------------------------------------------------------------
' Procedure : TableExists
' Purpose   : Check if the table exists
'---------------------------------------------------------------------------------------
'
Public Function TableExists(l_Tablename) As Boolean
On Error Resume Next
    DoCmd.DeleteObject objecttype:=acTable, objectname:=l_Tablename
    TableExists = (Err.Number = 0)
End Function
Now without the bugs (I hope):

Call ExportWysiwig( Me, "My Excelsheet")

'---------------------------------------------------------------------------------------
' Procedure : ExportWysiwyg
' Purpose   : Export me.recordset to Excel
'---------------------------------------------------------------------------------------
'
Public Function ExportWysiwyg(l_Source As Form, l_FN As String)
On Error GoTo ExportWysiwyg_Error
Const ProcName = "ExportWysiwyg"
Dim l_MeRS          As DAO.Recordset
Dim l_TmpName       As String
Dim l_TmpTable      As DAO.Recordset
Dim l_Field         As DAO.Field
Dim l_FD            As New cls_FileDialog
   
    ' Get a unique name for the temporary table and create the table
    Do: l_TmpName = "tmp_wysiwig" & CStr(Int((99999 * Rnd))): Loop While TableExists(l_TmpName)
    DoCmd.TransferDatabase acImport, "Microsoft Access", CurrentDb.name, acTable, l_Source.RecordSource, l_TmpName, True
    Set l_TmpTable = CurrentDb.OpenRecordset(l_TmpName, dbOpenDynaset)

    ' Copy all records from Me.Recordset to the temporary table
    Set l_MeRS = l_Source.RecordsetClone
    Do While Not l_MeRS.EOF
        l_TmpTable.AddNew
        For Each l_Field In l_MeRS.Fields
            l_TmpTable.Fields(l_Field.name).Value = l_Field.Value
        Next
        l_TmpTable.Update
        l_MeRS.MoveNext
    Loop

    ' Open a file-selector window
    With l_FD
       .DefaultFileName = l_FN
       .DefaultExt = "xls"
       .Filter1Text = "Excel document"
       .Filter1Suffix = "*.xls"
       .ShowSave
    End With
       
    ' Export the data to an Excel
    If Len(l_FD.FileName) > 0 Then DoCmd.TransferSpreadsheet acExport, , l_TmpName, l_FD.FileName

    ' Clean up
    l_MeRS.Close
    l_TmpTable.Close
    Set l_MeRS = Nothing
    Set l_TmpTable = Nothing
    CurrentDb.TableDefs.Delete l_TmpName

CleanExit:
    On Error GoTo 0
    Exit Function
ExportWysiwyg_Error:
    MsgBox Err.Description & " (" & Err.Number & ")"
    Resume CleanExit
End Function

'---------------------------------------------------------------------------------------
' Procedure : TableExists
' Purpose   : Check if the table exists
'---------------------------------------------------------------------------------------
'
Public Function TableExists(l_Tablename) As Boolean
On Error Resume Next
    DoCmd.DeleteObject objecttype:=acTable, objectname:=l_Tablename
    TableExists = (Err.Number = 0)
End Function
make sure you have the DAO reference checked. Because I used a resume next statement, it might not be capturing the fact that you don't have it. It works by the way, tested.
J
Sorry, what do you mean by "DAO reference checked"?
If you are in your VBA window, go to tools/references. Find the Microsoft DAO.3.6 (or some version) and check that box.
J
Oh, I see what you mean. I always compile my apps before distribution and Access will complain at that point if DAO isn't checked.
you put that code ON the form with the recordset right? you're trying to get the recordset for the subform as I recall...so how are you executing it?
J
Were we not able to provide an acceptable solution? There were outstanding questions.
>> you put that code ON the form with the recordset right? you're trying to get the recordset for the
>> subform as I recall...so how are you executing it?

The code itself is in a module so it can be reused. On the main form I have a button that executes the following line:
    Call ExportWysiwig( Me.frm_MySubform.Form, "My Excelsheet")
Basically you need to pass a handle to the relevant form, so in theory you could even run it for a different form:
    Call ExportWysiwig( Forms!frm_SomeOtherForm!frm_SomeOtherSubform.Form, "My Excelsheet")

However, if you execute this code twice (i.e. press the button twice without doing anything in between) for some weird reason the second time the Excel sheet is empty. It looks like my code somewhere empties Me.RecordsetClone. I fixed it by toggeling the FilterOn property.  It works, but it really is an ugly hack...

Furthermore, passing the form by reference is more efficient, so the routines now look as follows:
'---------------------------------------------------------------------------------------
' Procedure : ExportWysiwyg
' Purpose   : Export me.recordset to Excel
'---------------------------------------------------------------------------------------
'
Public Function ExportWysiwyg(ByRef l_Source As Form, l_FN As String)
On Error GoTo ExportWysiwyg_Error
Const ProcName = "ExportWysiwyg"
Dim l_MeRS          As DAO.Recordset
Dim l_TmpName       As String
Dim l_TmpTable      As DAO.Recordset
Dim l_Field         As DAO.Field
Dim l_FD            As New cls_FileDialog  

    ' Refresh the recordset
    If l_Source.FilterOn Then
        l_Source.FilterOn = False
        l_Source.FilterOn = True
    Else
        l_Source.FilterOn = True
        l_Source.FilterOn = False
    End If

    ' Get a unique name for the temporary table and create the table
    Do: l_TmpName = "tmp_wysiwig" & CStr(Int((99999 * Rnd))): Loop While TableExists(l_TmpName)
    DoCmd.TransferDatabase acImport, "Microsoft Access", CurrentDb.name, acTable, l_Source.RecordSource, l_TmpName, True
    Set l_TmpTable = CurrentDb.OpenRecordset(l_TmpName, dbOpenDynaset)

    ' Copy all records from Me.Recordset to the temporary table
    Set l_MeRS = l_Source.RecordsetClone
    Do While Not l_MeRS.EOF
        l_TmpTable.AddNew
        For Each l_Field In l_MeRS.Fields
            l_TmpTable.Fields(l_Field.name).Value = l_Field.Value
        Next
        l_TmpTable.Update
        l_MeRS.MoveNext
    Loop

    ' Open a file-selector window
    With l_FD
       .DefaultFileName = l_FN
       .DefaultExt = "xls"
       .Filter1Text = "Excel document"
       .Filter1Suffix = "*.xls"
       .ShowSave
    End With
       
    ' Export the data to an Excel file
    If Len(l_FD.FileName) > 0 Then DoCmd.TransferSpreadsheet acExport, , l_TmpName, l_FD.FileName

    ' Clean up
    l_MeRS.Close
    l_TmpTable.Close
    Set l_MeRS = Nothing
    Set l_TmpTable = Nothing
    CurrentDb.TableDefs.Delete l_TmpName

CleanExit:
    On Error GoTo 0
    Exit Function
ExportWysiwyg_Error:
    MsgBox Err.Description & " (" & Err.Number & ")"
    Resume CleanExit
End Function

'---------------------------------------------------------------------------------------
' Procedure : TableExists
' Purpose   : Check if the table exists
'---------------------------------------------------------------------------------------
'
Public Function TableExists(l_Tablename As String) As Boolean
On Error Resume Next
    DoCmd.DeleteObject objecttype:=acTable, objectname:=l_Tablename
    TableExists = (Err.Number = 0)
End Function
>> Were we not able to provide an acceptable solution? There were outstanding questions.

I really don't mind giving points to anyone who helps me solve a problem. If you check my record, you'll see that I have never been stingy. However, I don't see which part of your or PapaLorax's replies helped me to find a solution.

Don't get me wrong, I do appreciate you guys taking the time to reflect on my question and that is why I posted my code. That way we all can learn from it and hopefully it will be of use to others as well.

Having said that, I'd be happy to give you all the points graded A if you find a better solution to the above mentioned bug. It works as it is, but I just don't understand it.

regards,
Michiel
ASKER CERTIFIED SOLUTION
Avatar of Netminder
Netminder

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial