error 424 object requierd

[riic0]

Hallo,

Ik wil een form die ik heb gemaakt exporteren naar een excel spreadsheat.
Daar voor heb ik ergens een code vandaan gehaald maar als ik de code wil uitvoeren dan krijg ik : error 424 object requierd.
Dit is de code:
Public Function Send2Excel(Output As Form, Optional strSheetName As String)


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

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

ApXL.ActiveSheet.Cells.Select

ApXL.ActiveSheet.Cells.EntireColumn.AutoFit

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

Heb ik een verkeerde code of staat er iets verkeerd in?
Ik hoop dat iemand mij kan helpen.

Groeten,
Ricardo

 

[OctaFish]

Zou je de code willen opmaken met de CODE knop? (Knop # )

 

[riic0]

Public Function Send2Excel(Output As Form, Optional strSheetName As String)


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

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

ApXL.ActiveSheet.Cells.Select

ApXL.ActiveSheet.Cells.EntireColumn.AutoFit

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

 

[OctaFish]

Ik had eigenlijk gehoopt dat je de oorspronkelijke code zou opmaken; dat scheelt een extra metertje scrollen

Waar gaat de code de fout in? Ik zie bijvoorbeeld dat hier

Set xlWSh = xlWBk.Worksheets("Sheet1")
If Len(strSheetName) > 0 Then xlWSh.Name = Left(strSheetName, 34)

verwezen wordt naar strSheetName die ik eerder in de code niet tegenkom.

 

[riic0]

Ik heb het al opgelost door een andere code te gebruiken.

Sub Export_to_Excel_Click()
Dim Response As String
DoCmd.TransferSpreadsheet acExport, 8, "Output", "Output_Form.xls", True, ""

DoCmd.TransferSpreadsheet acExport, 8, "Output", "Output_Form.xls", True, ""
Response = MsgBox("Your file has been saved to your My Documents directory (usually C:\Desktop\Output_Form.xls).", vbOKOnly, "File Saved")
Exit Sub

End Sub

Maar bedankt voor je reactie