Export any form's recordset to Excel (1 Viewer)

'-----------------------------------------------------------------------------
' Procedure : Send2Excel
' Author    : Bob Larson
' Date      : 5/25/2008
' Purpose   : Send any single recordset form to Excel.  This will not work 
'             with subforms.
' Use       : You may freely use this code as long as the author information 
'             in this header remains intact
'-----------------------------------------------------------------------------
'
Public Function Send2Excel(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


    
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim intCount As Integer
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107

    On Error GoTo err_handler

    Set rst = frm.RecordsetClone

    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
    Do Until intCount = rst.Fields.Count
        ApXL.ActiveCell = rst.Fields(intCount).Name
        ApXL.ActiveCell.Offset(0, 1).Select
        intCount = intCount + 1
    Loop

    rst.MoveFirst
    xlWSh.Range("A2").CopyFromRecordset rst
    xlWSh.Range("1:1").Select
    ' This is included to show some of what you can do about formatting.  
    ' You can comment out or delete any of this that you don't want to 
    ' use in your own export.
    With ApXL.Selection.Font
        .Name = "Arial"
        .Size = 12
        .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
    ' selects the first cell to unselect all cells
    xlWSh.Range("A1").Select

    rst.Close
    Set rst = Nothing

    Exit Function
err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Exit Function

End Function

   Send2Excel Me, "SheetNamehere"

   Send2Excel Forms!YourFormNameHere, "SheetNameHere"