oxicottin
10-31-2019, 06:55 AM
Hello, I use a right click to print reports and attach as pdf but I cant figure out how to save to desktop as .pdf. The error I get says it contains the wrong number of arguments. Thoughts on how to grab the active reports name, I think that's the issue.
My module:
Public Function SaveOpenReportAsPDF(strReportName As String) As String
'========================================================================== ========================
'Create report and save as an attachment to the current record
'========================================================================== ========================
Dim myCurrentDir As String
Dim myReportOutput As String
Dim myMessage As String
On Error GoTo ErrorHandler
myCurrentDir = CurrentProject.Path & "\"
myReportOutput = myCurrentDir & strReportName & ".pdf"
If Dir(myReportOutput) <> "" Then ' the file already exists--delete it first.
VBA.SetAttr myReportOutput, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill myReportOutput ' delete the file.
End If
DoCmd.OutputTo acOutputReport, strReportName, acFormatPDF, myReportOutput, , , , acExportQualityPrint
SaveOpenReportAsPDF = myReportOutput
Exit Function
ErrorHandler:
MsgBox Error$
End Function
My Reports on load:
Private Sub Report_Load()
CreateReportShortcutMenu
End Sub
Private Sub CreateReportShortcutMenu()
'========================================================================== ========================
'//In the Report_Load Event enter CreateReportShortcutMenu then in the reports Property/Shortcut
' Menu Bar enter the MenuName "vbaShortCutMenu"
'
'//The numbers are Ms Access Control numbers you can download and excel file from MS
'
'//Reference: Microsoft Office 12.0 Object Library
'========================================================================== ========================
Dim MenuName As String
Dim CB As CommandBar
Dim CBB As CommandBarButton
MenuName = "vbaShortCutMenu"
On Error Resume Next
Application.CommandBars(MenuName).Delete
On Error GoTo 0
'The below code creates the menu I named vbaShortCutMenu
Set CB = Application.CommandBars.Add(MenuName, msoBarPopup, False, False)
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Print..."
CBB.Tag = "Print..."
CBB.FaceId = 3
CBB.OnAction = "=PrintActiveRptFrm()" 'Calls a module mod_ShortCutMenuCommands Public Function PrintActiveRptFrm()
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Send E-mail..."
CBB.Tag = "Send E-mail..."
CBB.OnAction = "=EmailAsPDF()" 'Calls a module mod_ShortCutMenuCommands Public Function EmailAsPDF()
Set CBB = CB.Controls.Add(msoControlButton, 12499, , , True)
CBB.Caption = "Save As pdf..."
CBB.Tag = "Save As pdf..."
CBB.FaceId = 3
CBB.OnAction = "=SaveOpenReportAsPDF()" 'Calls a module mod_ShortCutMenuCommands Public Function SaveOpenReportAsPDF()
'Adds the Close command.
'Set CBB = CB.Controls.Add(msoControlButton, 923, , , True)
'Starts a new group.
'CBB.BeginGroup = True
'Change the caption displayed for the control.
'CBB.Caption = "Close Report"
Set CB = Nothing
Set CBB = Nothing
End Sub
My module:
Public Function SaveOpenReportAsPDF(strReportName As String) As String
'========================================================================== ========================
'Create report and save as an attachment to the current record
'========================================================================== ========================
Dim myCurrentDir As String
Dim myReportOutput As String
Dim myMessage As String
On Error GoTo ErrorHandler
myCurrentDir = CurrentProject.Path & "\"
myReportOutput = myCurrentDir & strReportName & ".pdf"
If Dir(myReportOutput) <> "" Then ' the file already exists--delete it first.
VBA.SetAttr myReportOutput, vbNormal ' remove any file attributes (e.g. read-only) that would block the kill command.
VBA.Kill myReportOutput ' delete the file.
End If
DoCmd.OutputTo acOutputReport, strReportName, acFormatPDF, myReportOutput, , , , acExportQualityPrint
SaveOpenReportAsPDF = myReportOutput
Exit Function
ErrorHandler:
MsgBox Error$
End Function
My Reports on load:
Private Sub Report_Load()
CreateReportShortcutMenu
End Sub
Private Sub CreateReportShortcutMenu()
'========================================================================== ========================
'//In the Report_Load Event enter CreateReportShortcutMenu then in the reports Property/Shortcut
' Menu Bar enter the MenuName "vbaShortCutMenu"
'
'//The numbers are Ms Access Control numbers you can download and excel file from MS
'
'//Reference: Microsoft Office 12.0 Object Library
'========================================================================== ========================
Dim MenuName As String
Dim CB As CommandBar
Dim CBB As CommandBarButton
MenuName = "vbaShortCutMenu"
On Error Resume Next
Application.CommandBars(MenuName).Delete
On Error GoTo 0
'The below code creates the menu I named vbaShortCutMenu
Set CB = Application.CommandBars.Add(MenuName, msoBarPopup, False, False)
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Print..."
CBB.Tag = "Print..."
CBB.FaceId = 3
CBB.OnAction = "=PrintActiveRptFrm()" 'Calls a module mod_ShortCutMenuCommands Public Function PrintActiveRptFrm()
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Send E-mail..."
CBB.Tag = "Send E-mail..."
CBB.OnAction = "=EmailAsPDF()" 'Calls a module mod_ShortCutMenuCommands Public Function EmailAsPDF()
Set CBB = CB.Controls.Add(msoControlButton, 12499, , , True)
CBB.Caption = "Save As pdf..."
CBB.Tag = "Save As pdf..."
CBB.FaceId = 3
CBB.OnAction = "=SaveOpenReportAsPDF()" 'Calls a module mod_ShortCutMenuCommands Public Function SaveOpenReportAsPDF()
'Adds the Close command.
'Set CBB = CB.Controls.Add(msoControlButton, 923, , , True)
'Starts a new group.
'CBB.BeginGroup = True
'Change the caption displayed for the control.
'CBB.Caption = "Close Report"
Set CB = Nothing
Set CBB = Nothing
End Sub