Mike,
I generally hide the ribbon from my users, and continue to use shortcut
menus. Here is the code for a custom Report menu I use in most of my
applications. I generally use the Report_Open event to call MenuReport,
followed immediately by setting the reports ShortcutMenuBar.
Private Sub Report_Open
Call MenuReport
Me.ShortcutMenuBar = "myReportMenu"
End Sub
This way, regardless of whether I open the report from code, or via the
navpane, I know the shortcut is operational. Then all you have to do is
right click on the report for a variety of functions.
DisplayError is a subroutine I use to record error messages in my ErrorLog
table, so you will need to replace calls to that subroutine with some other
error handling process.
The function IsPDFInstalled checks to see whether the Microsoft SaveAsPDF
add-in is installed. If so, it adds functionalit to either save or send the
report as a pdf.
------
HTH
Dale
Public Sub MenuReport(Optional Reset As Boolean = False)
Dim cbr As Object 'As CommandBar
Dim cbrButton As Object
Dim cbrCombo As Object 'CommandBarComboBox
Dim cbrCombo1 As Object, cbrCombo2 As Object
Dim cbrEdit As Object
Dim strSQL As String
Dim rs As DAO.Recordset
If CmdBarExists("MyReportMenu") Then
If Reset = False Then
Exit Sub
Else
DeleteCmdBar ("MyReportMenu")
End If
End If
On Error GoTo ReportMenuError
DoCmd.Hourglass True
Set cbr = CommandBars.Add("MyReportMenu", BarPopup, , True)
With cbr
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.Caption = "&Print"
.Tag = "Print"
.OnAction = "=fnReportPrint()"
End With
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.Caption = "Save as &RTF"
.Tag = "Save as RTF"
.OnAction = "=fnReportSave('RTF')"
.begingroup = True
End With
If IsPDFInstalled() = True Then
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.Caption = "Save as &PDF"
.Tag = "Save as PDF"
.OnAction = "=fnReportSave('PDF')"
End With
End If
Set cbrCombo = cbr.Controls.Add(ControlComboBox, , , , True)
With cbrCombo
.Width = 0.25
If (Application.Version = 12) And (IsPDFInstalled = True) Then
.AddItem "PDF"
End If
.AddItem "RTF"
.Caption = "Send as:"
.Tag = "SendReport"
.OnAction = "=fnReportSend()"
.begingroup = True
End With
Set cbrButton = cbr.Controls.Add(ControlButton, , , , True)
With cbrButton
.Caption = "&Close"
.Tag = "Close"
.OnAction = "=fnReportClose()"
.begingroup = True
End With
End With
DoCmd.Hourglass False
Exit Sub
ReportMenuError:
MsgBox Err.Number & vbCrLf & Err.Description, , "ReportMenu error"
End Sub
Public Function fnReportPrint()
Dim rpt As Report, strRptName As String
Dim strMsg As String
Dim intResponse As Integer, bPrint As Boolean
On Error GoTo PrintReportError
Set rpt = Reports(Reports.Count - 1)
strRptName = rpt.Name
bPrint = True
If rpt.Pages > 10 Then
strMsg = "This report contains " & rpt.Pages & " pages! " _
& vbCrLf & vbCrLf _
& "Print this report anyway?"
intResponse = MsgBox(strMsg, vbOKCancel, "Excessive pages")
If intResponse = vbCancel Then bPrint = False
End If
If bPrint Then
With rpt
Application.RunCommand acCmdPrint
End With
End If
Exit Function
PrintReportError:
If Err.Number = 2501 Then
'do nothing (print was cancelled)
Else
DisplayError ("Error in fnReportPrint")
End If
End Function
Public Function fnReportSave(OutputFormat As String)
Dim rpt As Report
On Error GoTo SaveReportError
If Reports.Count = 0 Then
Exit Function
Else
Set rpt = Reports(Reports.Count - 1)
End If
Select Case OutputFormat
Case "HTML"
DoCmd.OutputTo acOutputReport, rpt.Name, acFormatHTML, , True
Case "RTF"
DoCmd.OutputTo acOutputReport, rpt.Name, acFormatRTF, , True
Case "PDF"
DoCmd.OutputTo acOutputReport, rpt.Name, "PDF Format (*.pdf)", ,
True
Case Else
'do nothing
End Select
SaveReportExit:
Exit Function
SaveReportError:
If Err.Number = 2501 Then
Exit Function
ElseIf Err.Number = 2282 Then
MsgBox WrapText("Your system does not currently have the ability to
save a file " _
& "in a PDF format." & vbCrLf _
& "Contact your system administrator to request
addition of this " _
& "functionality to your suite of MS Office tools!", 65)
Else
DisplayError ("Error encountered while printing report")
End If
End Function
Public Function fnReportSend()
Dim cbr As Object
Dim cbrCombo As Object
Dim strFormat As String
Dim rpt As Report, strReport As String
Dim rs As DAO.Recordset
Set rpt = Reports(Reports.Count - 1)
strReport = rpt.Name
Set cbr = CommandBars("MyReportMenu")
Set cbrCombo = cbr.FindControl(Tag:="SendReport")
If cbrCombo.ListCount = 1 Or cbrCombo.ListIndex = 2 Then
strFormat = acFormatRTF
Else
strFormat = "PDF Format (*.pdf)"
End If
On Error GoTo ReportSendError
DoCmd.SendObject acSendReport, strReport, strFormat, , , , "AWFC\LD
Details", , True
ReportSendExit:
Exit Function
ReportSendError:
If Err.Number = 2501 Then
MsgBox "Send email was cancelled!"
ElseIf Err.Number = 2282 Then
MsgBox WrapText("Your system does not currently have the ability to
save a file " _
& "in a PDF format." & vbCrLf _
& "Contact your system administrator to request
addition of this " _
& "functionality to your suite of MS Office tools!", 65)
Else
DisplayError ("Error encounterd during fnSendReport!")
End If
End Function
Public Function fnReportClose()
Dim rpt As Report
Dim strMsg As String
Dim intResponse As Integer, bPrint As Boolean
On Error GoTo fnReportCloseError
If Reports.Count > 0 Then
DoCmd.Close acReport, Reports(Reports.Count - 1).Name
End If
Exit Function
fnReportCloseError:
If Reports.Count > 0 Then strMsg = " Report: '" & Reports(Reports.Count
- 1).Name & "'"
strMsg = "Error encountered in fnCloseReport():" & strMsg
DisplayError (strMsg)
End Function
Public Function IsPDFInstalled(Optional Reset As Boolean) As Boolean
'Checks to see whether the computer has the PDF add-in for 2007.
'Since 2003 does not have a PDF add-in, it automatically returns a False
if the Access version
'is prior to 2007. Otherwise it tries to save a file as pdf and if the
process generates an
'error, returns False (0)
Static MyPDF As Variant
Dim strFilename As String
Dim strOutputFormat As String
On Error GoTo PDFError
If Not IsEmpty(MyPDF) And (Reset = False) Then
'do nothing
ElseIf Val(Application.Version) < 12 Then
MyPDF = False
Else
strFilename = fGetSpecialFolderLocation(CSIDL_PERSONAL) _
& "\Text" & Format(Now(), "yymmddhhnnss") & ".pdf"
DoCmd.Echo False
DoCmd.OutputTo acOutputTable, "local_Numbers", acFormatPDF,
strFilename, False
Kill strFilename
MyPDF = True
End If
PDFExit:
IsPDFInstalled = MyPDF
DoCmd.Echo True
Exit Function
PDFError:
MyPDF = False
Resume PDFExit
End Function
Public Function CmdBarExists(BarName As String) As Boolean
Dim intControls
On Error Resume Next
intControls = CommandBars(BarName).Controls.Count
If Err.Number = 0 Then
CmdBarExists = True
Else
CmdBarExists = False
End If
End Function
Public Sub DeleteCmdBar(BarName As String)
Dim intLoop As Integer
'If an error is generated, it is because the command bar doesn't exist,
ignore it
On Error GoTo DeleteCmdBar_Error
CommandBars(BarName).Delete
Exit Sub
DeleteCmdBar_Error:
Err.Clear
End Sub
