PreviewReport Function
This custom function is the simplest and safest way to preview reports in any Microsoft Access application.
There are several things that annoy me about the default behavior of DoCmd.OpenReport. To address these annoyances, I built a replacement function that I named PreviewReport().
In this series of articles, I went through the evolution of this function as I addressed each of my frustrations with DoCmd.OpenReport:
- Auto-Print: Opening a report sends it directly to the printer with no on-screen preview
- Wrong Data: If you call OpenReport on a report that's already open, Access doesn't apply the new criteria to the report
- Unwarranted Errors: When you cancel report opening in the OnNoData event, Access raises an error
- Cascading Maximize: If you open a report from a windowed form, maximize the report, then close it, the windowed form from which you opened the report gets maximized
- Missing OpenArgs: Prior to Access 2007, OpenArgs was not supported for the OpenReport method
The Code
Without further ado, here is the finished product.
Note: In Part 3 of the series, I mentioned that the version of the PreviewReport function that I use within my own applications relies on a global vbWatchdog error handler. The version I'm presenting here does not require vbWatchdog. The vbWatchdog-only version--which I decided not to include--is nearly identical to the code shown here, except that it omits the "On Error Goto" line and the final block of mostly boilerplate error-handling code. The code below will work perfectly fine with or without vbWatchdog.
'---------------------------------------------------------------------------------------
' Procedure : PreviewReport (vbWatchdog optional)
' Author : Mike Wolfe (https://nolongerset.com/previewreport-function/)
' Purpose : Opens a report in preview mode, optionally applying a Where condition.
' Notes - Returns False if report did not open (likely due to a NoData cancel event)
' - Closes existing report if currently open so that proper filter is applied
' - Adjusts size of report to fill available Access client window but without
' actually maximizing the report; workaround for hard crash in Access 2007
' (see: https://stackoverflow.com/q/24460881/154439)
' - Supports the OpenArgs parameter introduced in Access 2007
' without breaking compile on earlier versions
' - Requires a vbWatchdog global error handler that applies
' On Error Resume Next handling to every instance of error 2501
'---------------------------------------------------------------------------------------
'
Function PreviewReport(RptName As String, _
Optional Where As String = "", _
Optional OpenArgs As String = "") As Boolean
On Error GoTo Err_PreviewReport
'Avoid "Syntax error (missing operator) in query expression" errors
If Right$(Trim$(Where), 1) = "=" Then Exit Function
Dim IsMaxed As Boolean, ActiveHwnd As Long
ActiveHwnd = ActiveObjectHwnd
If ActiveHwnd <> 0 Then
IsMaxed = IsMaximized(ActiveHwnd)
Else
IsMaxed = False
End If
If ReportIsOpen(RptName) Then DoCmd.Close acReport, RptName
'OpenArgs for reports was added in Access 2007
If CSng(SysCmd(acSysCmdAccessVer)) >= 12 And Len(OpenArgs) > 0 Then
'Workaround to allow code to compile in versions of Access prior to Access 2007
Dim AccessApp As Object
Set AccessApp = Application
AccessApp.DoCmd.OpenReport RptName, acViewPreview, , Where, , OpenArgs
Else
DoCmd.OpenReport RptName, acViewPreview, , Where
End If
'No error was raised; the report must have opened successfully
PreviewReport = True
If Not IsMaxed Then
FillAccessWindow Reports(RptName).hWnd
'We call it a second time because the first call may
' add scroll bars/status bars that need to be accounted for
DoEvents
FillAccessWindow Reports(RptName).hWnd
End If
Exit_PreviewReport:
Exit Function
Err_PreviewReport:
Select Case Err.Number
Case 2501 'The OpenReport action was canceled.
PreviewReport = False
Case Else
MsgBox Err.Description, vbExclamation, "Error: " & Err.Number
End Select
Resume Exit_PreviewReport
End FunctionPrerequisite code
The PreviewReport function listed above calls several other functions that I've previously published, including:
For convenience, I've reproduced the required code below for easy copy-and-pasting into your applications:
'--== Prerequisites for the PreviewReport() function ==--
Private Type rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, _
ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
#Else
Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function apiGetClientRect Lib "user32" Alias "GetClientRect" (ByVal hWnd As LongPtr, lpRect As rect) As Long
#Else
Private Declare Function apiGetClientRect Lib "user32" Alias "GetClientRect" (ByVal hWnd As Long, lpRect As rect) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function apiFindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As LongPtr
#Else
Private Declare Function apiFindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function apiGetParent Lib "user32" _
Alias "GetParent" _
(ByVal hWnd As LongPtr) _
As LongPtr
#Else
Private Declare Function apiGetParent Lib "user32" _
Alias "GetParent" _
(ByVal hWnd As Long) _
As Long
#End If
'Functions return 1 for true and 0 for false; multiply result by -1 for safer Boolean use
#If VBA7 Then
Private Declare PtrSafe Function IsZoomed Lib "user32" (ByVal hWnd As LongPtr) As Integer
#Else
Private Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Integer
#End If
'----------------------------------------------------
' Procedure : FillAccessWindow
' Author : Mike Wolfe <mike@nolongerset.com>
' Source : https://nolongerset.com/fun-with-form-windows/
'
'Used to set the window size of an Access form or report
'Usage A: Fill the available screen space
' FillAccessWindow Frm.Hwnd
'
'Usage B: Maximize the form or report while maintaining a given ratio (a square in this example)
' FillAccessWindow Frm.Hwnd, 1
'
'Usage C: A tall window anchored to the upper right corner of available space
' FillAccessWindow Frm.Hwnd, 2.5, "NE"
'
'Usage D: Arrange four forms to fill the corners of the available space
' FillAccessWindow FrmA.Hwnd, , "NW", 0.5, 0.5
' FillAccessWindow FrmB.Hwnd, , "NE", 0.5, 0.5
' FillAccessWindow FrmC.Hwnd, , "SE", 0.5, 0.5
' FillAccessWindow FrmD.Hwnd, , "SW", 0.5, 0.5
'
Sub FillAccessWindow(Optional ChildHWnd As Long, _
Optional HtToWdRatio As Double = 0, _
Optional AnchorLoc As String = "NW", _
Optional HeightToCanvasRatio As Double = 1, _
Optional WidthToCanvasRatio As Double = 1)
Dim hWnd As Long, Canvas As rect
hWnd = GetHWnd(ChildHWnd)
Canvas = GetCanvas(hWnd)
Dim wd As Long, ht As Long
wd = (Canvas.Right - Canvas.Left) * WidthToCanvasRatio
ht = (Canvas.Bottom - Canvas.Top) * HeightToCanvasRatio
'Handle the case where we want to maintain a specific Height-to-Width ratio
If HtToWdRatio <> 0 Then
Dim CanvasHtToWdRatio As Double
CanvasHtToWdRatio = (Canvas.Bottom - Canvas.Top) / (Canvas.Right - Canvas.Left)
If CanvasHtToWdRatio > HtToWdRatio Then
ht = wd * HtToWdRatio
Else
wd = ht / HtToWdRatio
End If
End If
'Move and resize the window
Select Case AnchorLoc
Case "Center"
apiMoveWindow hWnd, (Canvas.Right - wd) / 2, (Canvas.Bottom - ht) / 2, wd, ht, True
Case "NE"
apiMoveWindow hWnd, Canvas.Right - wd, 0, wd, ht, True
Case "SE"
apiMoveWindow hWnd, Canvas.Right - wd, Canvas.Bottom - ht, wd, ht, True
Case "SW"
apiMoveWindow hWnd, 0, Canvas.Bottom - ht, wd, ht, True
Case Else '"NW"
apiMoveWindow hWnd, 0, 0, wd, ht, True
End Select
End Sub
'Returns HWnd if <> 0, else the window handle of the active on-screen object
Private Function GetHWnd(hWnd As Long) As Long
On Error Resume Next
GetHWnd = hWnd
If GetHWnd = 0 Then GetHWnd = Screen.ActiveForm.hWnd
If GetHWnd = 0 Then GetHWnd = Screen.ActiveReport.hWnd
If GetHWnd = 0 Then GetHWnd = Screen.ActiveDatasheet.hWnd
End Function
Function GetCanvas(Optional ByVal ChildHWnd As Long) As rect
Dim CanvasHwnd As Long
CanvasHwnd = GetInnerAccessHwnd(ChildHWnd)
apiGetClientRect CanvasHwnd, GetCanvas
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetInnerAccessHwnd
' Author : Mike Wolfe
' Date : 11/26/2014
' Purpose : Gets the window handle of the Access "canvas".
' Notes - We don't use HWndAccessApp here because that's the window handle for the
' full application; what we really want is the handle for the "inner container";
' ie, the Access window minus the docked menus, docked toolbars, and status bar
'---------------------------------------------------------------------------------------
'
Function GetInnerAccessHwnd(Optional ByVal ChildHWnd As Long = 0) As Variant 'Variant used instead of Conditional Compile (Long needed for 32bit LongPtr needed for 64bit)
GetInnerAccessHwnd = apiFindWindowEx(hWndAccessApp, ByVal 0&, "MDIClient", vbNullString)
If GetInnerAccessHwnd <> 0 Then Exit Function
On Error Resume Next
If ChildHWnd = 0 Then ChildHWnd = Screen.ActiveForm.hWnd
If ChildHWnd = 0 Then ChildHWnd = Screen.ActiveReport.hWnd
If ChildHWnd = 0 Then ChildHWnd = Screen.ActiveDatasheet.hWnd
GetInnerAccessHwnd = apiGetParent(ChildHWnd)
End Function
'source: https://nolongerset.com/get-a-handle-on-window-state/
Function IsMaximized(hWnd As Long) As Boolean
IsMaximized = IsZoomed(hWnd) * -1
End Function
'source: https://nolongerset.com/why-so-lazy-access/
Function ReportIsOpen(RptName As String) As Boolean
ReportIsOpen = (SysCmd(acSysCmdGetObjectState, acReport, RptName) <> 0)
End Function
'source: https://nolongerset.com/avoid-the-cascading-maximize/
Function ActiveObjectHwnd() As Long
On Error Resume Next
ActiveObjectHwnd = Screen.ActiveForm.hWnd
If ActiveObjectHwnd <> 0 Then Exit Function
ActiveObjectHwnd = Screen.ActiveReport.hWnd
If ActiveObjectHwnd <> 0 Then Exit Function
ActiveObjectHwnd = Screen.ActiveDatasheet.hWnd
End FunctionImage by mohamed Hassan from Pixabay
