PreviewReport Function
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