Evolution of a Function: ShowForm() Part 3

Mike Wolfe -

This is Part 3 of a series on the evolution of my ShowForm() function.

In part 2 of this series, we added the ability to create multiple form instances of a single form.

We added that feature to let the user compare data side by side while avoiding the downsides of creating and maintaining multiple copies of a form.  Creating multiple form instances as opposed to multiple form copies has the following advantages:

  1. Easier ongoing maintenance
  2. More scalable
  3. Easier to track which form object to open
  4. Simplified calling code

Improvements Added in Part 3

After using the Part 2 version of ShowForm() for awhile, I discovered several things that I could do to improve it:

  • Refactor to reduce code nesting
  • Prevent multiple form instances from stacking on top of each other
  • Avoid opening multiple instances of the same data
  • Support OpenArgs in Form Open/Load events of multi-instance forms
  • Ensure forms open at their full size if possible
  • Improve the debugging experience with the extra Resume

Use Guard Clause to Reduce Code Nesting

In Part 2, we wrapped the entire function's body inside the following If...Then clause:

If Right(Where, 1) <> "=" Then
    '...
End If

This introduced an unnecessary level of nesting and contributed to the arrow-shaped nature of our code.

To remove this extra level of nesting and improve readability of the function, I replaced the above code with an equivalent guard clause:

If Right(Where, 1) = "=" Then GoTo Exit_ShowForm

Cascading Multiple Form Instances

One problem with the Part 2 solution is that each new instance of the form opened up on top of the previous one.  If you use Overlapping Windows (my personal preference), then this severely detracts from the multi-form-instance user experience (UX).

To improve upon the Part 2 UX, we're going to incorporate my CascadeForm() function into ShowForm().

CascadeForm(): Prevent Multi-Instance Forms From Hiding Behind Each Other
The CascadeForm() function introduces the cascading-window effect from the Windows operating system to Microsoft Access.
No Longer SetMike Wolfe

Avoiding Multiple Instances of the Same Data

Another issue with the Part 2 solution is that the user could open multiple forms that referenced the same underlying record.

That's because every time the user called ShowForm() for a compatible multi-instance form, the function added an entry to a collection keyed on the form's window handle.  So, if we called the following code...

ShowForm "frmMSysObjects", "Name='Reports'"
ShowForm "frmMSysObjects", "Name='Reports'"
ShowForm "frmMSysObjects", "Name='Forms'"
ShowForm "frmMSysObjects", "Name='Reports'"

...then we would have 3 instances of the form showing the "Reports" data and 1 instance showing the "Forms" data.  

What we would prefer after making the above calls is to have only 2 instances of the frmMSysObjects form: one showing "Reports" data and one showing "Forms" data.

To do this, I changed from keying the collection based on the forms' window handles and instead created a compound key string based on the forms' names and where clauses:

    Key = FormName & "§" & Where
    If Not IsMissing(OpenArgs) Then Key = Key & "§" & OpenArgs
    On Error Resume Next
    Set Frm = FormCollection(Key)
    On Error GoTo Err_ShowForm
    
    If Not Frm Is Nothing Then
        Frm.SetFocus
        GoTo Exit_ShowForm
    End If

If there is already an open form that matches the name and where clause of the calling code, then we give it the focus and exit immediately.

Support for OpenArgs in Form Load/Open Events

My first multi-instance form included a tab control.

In the form's Load event, I would show a particular tab based on an optional OpenArgs parameter that I would pass via DoCmd.OpenForm.  To create multiple form instances in Access, you have to create new instances of the associated form class (i.e., the code-behind module).  Unfortunately, VBA does not allow you to pass arguments to class constructors.

By the time I passed the OpenArgs argument to the new class instance, the form's Load (and Open) event had already run.

I needed some way to run code after the Load and Open events but before the form was made visible to the user.  Sticking with the concept of using the minimum effort necessary, I created a Public Sub named PreShow() in the form's code-behind module.  

Here's what the code change looked like in the code-behind module for my "ConceptDetail" form object:

To allow support for future multi-instance forms that did not include a PreShow() subroutine, I wrapped the call to .PreShow in an On Error Resume Next block within ShowForm():

        On Error Resume Next
        Frm.PreShow
        On Error GoTo Err_ShowForm

Ensure Forms Open Full-Size

This is a simple quality of life improvement for our end users.

It ensures that if we save a form's opening position somewhere other than the far top-left corner of the Access canvas, the form won't get chopped off if the user happens to have the main Access window sized too small to fit the whole form on-screen.

If Not Frm Is Nothing Then KeepFormOnCanvas Frm

See the article below for details and example screenshots.

KeepFormOnCanvas(): Get Back Here, Form!
What happens if the user resizes their Access window so that our form can’t open in its entirety? KeepFormOnCanvas() to the rescue!
No Longer SetMike Wolfe

Improve Debugging with the Extra Resume

Adding a so-called "extra Resume" that your code can never reach at runtime is a handy way to save time when debugging.  See link below for details.

Exit_ShowForm:
    Exit Function
Err_ShowForm:
    MsgBox Err.Description, , "Error " & Err.Number
    'LogError Err.Number, Err.Description, "ShowForm", "FormFunctions Module"
    Resume Exit_ShowForm
    Resume                 '  <---  the "Extra Resume"
End Function
The Extra Resume
Want an easy way to jump to the line that raised the error AND avoid the infinite loop time bomb? Add an extra Resume.
No Longer SetMike Wolfe

Code Changes from Part 2

The screenshot below uses KDiff3 to highlight the differences between versions 2 and 3 of the ShowForm function:

ShowForm() Part 3: Actual Code

FormFunctions Module

Option Compare Database
Option Explicit

Private FormCollection As Collection

'https://nolongerset.com/showform-part-3/
'Updated : 11/18/2011 9:46
'Requires: Private FormCollection As Collection  in module declaration section
'        : KeepFormOnCanvas, CascadeForm function from WindowFunctions module
Function ShowForm(FormName As String, _
                  Optional Where As String = "", _
                  Optional OpenArgs As Variant)    'vv
Dim Frm As Form, Key As String
    On Error GoTo Err_ShowForm

    If Right(Where, 1) = "=" Then GoTo Exit_ShowForm

    Key = FormName & "§" & Where
    If Not IsMissing(OpenArgs) Then Key = Key & "§" & OpenArgs
    On Error Resume Next
    Set Frm = FormCollection(Key)
    On Error GoTo Err_ShowForm
    
    If Not Frm Is Nothing Then
        Frm.SetFocus
        GoTo Exit_ShowForm
    End If
    
    Select Case FormName
    Case "frmMSysObjects"
        Set Frm = New Form_frmMSysObjects
    End Select
    
    
    If Frm Is Nothing Then
        If FormIsOpen(FormName) Then DoCmd.Close acForm, FormName
        DoCmd.OpenForm FormName, acNormal, , Where, , , OpenArgs
        On Error Resume Next
        Set Frm = Forms(FormName)
        On Error GoTo Err_ShowForm
    Else
        If FormCollection Is Nothing Then Set FormCollection = New Collection
        If Len(Where) > 0 Then
            Frm.FilterOn = True
            Frm.Filter = Where
        End If
        If Not IsMissing(OpenArgs) Then Frm.OpenArgs = OpenArgs
        On Error Resume Next
        Frm.PreShow
        On Error GoTo Err_ShowForm
        CascadeForm Frm
        Frm.Visible = True
        FormCollection.Add Frm, Key
    End If
    If Not Frm Is Nothing Then KeepFormOnCanvas Frm

Exit_ShowForm:
    Exit Function
Err_ShowForm:
    MsgBox Err.Description, , "Error " & Err.Number
    'LogError Err.Number, Err.Description, "ShowForm", "FormFunctions Module"
    Resume Exit_ShowForm
    Resume
End Function

'Purpose: Maintains the module-level FormCollection
'           by removing window handles from the collection
'           as their associated forms are closed
'Usage: in Form's Close property sheet event: =RemoveForm([Hwnd])
Function RemoveForm(hWnd)
Dim Obj As Object, DoRemove As Boolean
    
    On Error GoTo Err_RemoveForm

    For Each Obj In FormCollection
        If Obj.hWnd = hWnd Then
            DoRemove = True
            Exit For
        End If
    Next Obj
        
    If DoRemove Then
        Set Obj = Nothing
        FormCollection.Remove CStr(hWnd)
    End If

Exit_RemoveForm:
    Exit Function
Err_RemoveForm:
    Select Case Err.Number
    Case Else
        MsgBox Err.Description, , "Error " & Err.Number
        'LogErr Err, Errors, "FormFunctions", "RemoveForm"
    End Select
    Resume Exit_RemoveForm
End Function

'https://nolongerset.com/why-so-lazy-access/
Function FormIsOpen(FormName As String) As Boolean
    FormIsOpen = (SysCmd(acSysCmdGetObjectState, acForm, FormName) <> 0)
End Function

WindowFunctions module

Option Compare Database
Option Explicit

Private Type Rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

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
    
Private Declare PtrSafe Function apiGetParent Lib "user32" _
    Alias "GetParent" (ByVal hWnd As LongPtr) As LongPtr

Private Declare PtrSafe Function apiGetWindowRect Lib "user32" _
    Alias "GetWindowRect" (ByVal hWnd As LongPtr, lpRect As Rect) As Long
    
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
    
Private Declare PtrSafe Function apiGetClientRect Lib "user32" _
    Alias "GetClientRect" (ByVal hWnd As LongPtr, _
                           lpRect As Rect) As Long

Private Declare PtrSafe Function GetDC Lib "user32" _
    (ByVal hWnd As LongPtr) As LongPtr

Private Declare PtrSafe Function ReleaseDC Lib "user32" _
    (ByVal hWnd As LongPtr, _
     ByVal hdc As LongPtr) As Long

Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _
    (ByVal hdc As LongPtr, _
    ByVal nIndex As Long) As Long

Private Const WU_LOGPIXELSX = 88
Private Const WU_LOGPIXELSY = 90

' ----------------------------------------------------------------
' Procedure : CascadeForm
' Date      : 7/17/2023
' Author    : Mike Wolfe
' Source    : https://nolongerset.com/cascadeform/
' Purpose   : Prevent multiple instances of a form from opening on top of each other.
' Requires  - GetInnerAccessHwnd()
'           - KeepFormOnCanvas()
'           - apiGetWindowRect() API call
'           - apiMoveWindow() API call
' ----------------------------------------------------------------
Sub CascadeForm(Frm As Form)
    Const pBuffer = 30    'buffer, in pixels

    'Maintain a collection of Depth values keyed by form name
    Static FormDepth As Collection
    If FormDepth Is Nothing Then Set FormDepth = New Collection
    
    'Attempt to get the form's current Depth value
    Dim Depth As Long
    On Error Resume Next
    Depth = FormDepth(Frm.Name)
    FormDepth.Remove Frm.Name
    On Error GoTo 0
    
    'Get the window handle for the Access "canvas"
    Dim CanvasHwnd As LongPtr
    CanvasHwnd = GetInnerAccessHwnd()
    
    'Get the Rectangle values for the Access window
    Dim pAccWindow As Rect
    apiGetWindowRect CanvasHwnd, pAccWindow
    
    'Get the Rectangle values for the passed form
    Dim pFormRect As Rect
    apiGetWindowRect Frm.hWnd, pFormRect
    
    'Move the window down and to the right (relative to previous instance)
    apiMoveWindow Frm.hWnd, _
                  pFormRect.Left - pAccWindow.Left + (pBuffer * Depth), _
                  pFormRect.Top - pAccWindow.Top + (pBuffer * Depth), _
                  pFormRect.Right - pFormRect.Left, _
                  pFormRect.Bottom - pFormRect.Top, _
                  True
                  
    'Move form to keep it on canvas if necessary
    If KeepFormOnCanvas(Frm) Then
        'If this form didn't fit on screen, reset the next one
        '   to use the original position...
        FormDepth.Add 0, Frm.Name
    Else
        '...otherwise, increment the depth so that the next instance
        '   cascades down and to the right of this one
        FormDepth.Add Depth + 1, Frm.Name
    End If

End Sub




'---------------------------------------------------------------------------------------vv
' Procedure : KeepFormOnCanvas
' Author    : Mike
' Date      : 11/1/11 - 10/8/14 10:23
' Purpose   : Ensures a form fits within the Access window.
' Notes     - Naming conventions (p: Pixels; t: Twips)
' Returns   - True if form did not fit within the Access window
'           - False if the form did fit
'---------------------------------------------------------------------------------------
'^^
Function KeepFormOnCanvas(tFrm As Form, Optional MinDetailSections As Integer = 5) As Boolean
    Const TwipsPerInch = 1440, tNavBarHeight = 270, acDefViewContinuous = 1
    Const tRecSelWidth = 263, tVertScrollWidth = 255
    Dim pAppCanvas As Rect, pAppRect As Rect, pFormRect As Rect, pFormCanvas As Rect
    Dim pVAppBuffer As Long, pHAppBuffer As Long, pVBuffer As Long, pHBuffer As Long
    
    #If VBA7 Then
        Dim DeviceContext As LongPtr
    #Else
        Dim DeviceContext As Long
    #End If
    
    Dim XPixelsPerInch As Long, YPixelsPerInch As Long
    
    Dim pFormWidth As Long, pFormHeight As Long, tFormWidth As Long, tFormHeight As Long
    Dim pNewLeft As Long, pNewWidth As Long
    Dim pNewTop As Long, pNewHeight As Long

    Dim CanvasHwnd As Variant 'Long/LongPtr
    CanvasHwnd = GetInnerAccessHwnd(tFrm.hWnd)
    
    apiGetWindowRect CanvasHwnd, pAppRect
    apiGetClientRect CanvasHwnd, pAppCanvas
    apiGetWindowRect tFrm.hWnd, pFormRect
    apiGetClientRect tFrm.hWnd, pFormCanvas


    'Get screen resolution (Pixels/Inch)
    DeviceContext = GetDC(tFrm.hWnd)
    XPixelsPerInch = GetDeviceCaps(DeviceContext, WU_LOGPIXELSX)
    YPixelsPerInch = GetDeviceCaps(DeviceContext, WU_LOGPIXELSY)
    ReleaseDC tFrm.hWnd, DeviceContext

    'The Buffers are the amount of space (in pixels) lost to the bounding window box at top/bottom and left/right
    pVBuffer = (pFormRect.Bottom - pFormRect.Top) - (pFormCanvas.Bottom - pFormCanvas.Top)
    pHBuffer = (pFormRect.Right - pFormRect.Left) - (pFormCanvas.Right - pFormCanvas.Left)
    pVAppBuffer = (pAppRect.Bottom - pAppRect.Top) - (pAppCanvas.Bottom - pAppCanvas.Top)
    pHAppBuffer = (pAppRect.Right - pAppRect.Left) - (pAppCanvas.Right - pAppCanvas.Left)

    'Calculate the full form width
    tFormWidth = tFrm.Width
    'Add width of record selectors
    If tFrm.RecordSelectors Then tFormWidth = tFormWidth + tRecSelWidth
    'Add width of vertical scroll bar
    If tFrm.ScrollBars And 2 Then tFormWidth = tFormWidth + tVertScrollWidth
    'Translate form width from twips to pixels (truncate instead of rounding to prevent 1-pixel "growth" of forms)
    pFormWidth = Int(tFormWidth / TwipsPerInch * XPixelsPerInch) + pHBuffer

    'Fit form on screen horizontally
    If pFormRect.Right >= pAppCanvas.Right + pAppRect.Left Or pFormCanvas.Bottom = 0 Then
        KeepFormOnCanvas = True
        pNewLeft = pAppCanvas.Right - pFormWidth
        pNewWidth = pFormWidth
    ElseIf pFormRect.Left < pAppRect.Left Then
        'reposition windows to the left of the Access canvas (can only occur with dialog windows)
        KeepFormOnCanvas = True
        pNewLeft = pAppRect.Left
        pNewWidth = pFormRect.Right - pFormRect.Left
    Else
        pNewLeft = pFormRect.Left - pAppRect.Left - (pHAppBuffer / 2)
        pNewWidth = pFormRect.Right - pFormRect.Left
    End If
    'Calculate the full form height
    tFormHeight = tFrm.Section(acDetail).Height
    'If continuous form will not fit on screen, try to get at least some minimum number of rows to show
    If tFrm.DefaultView = acDefViewContinuous Then
        tFormHeight = tFrm.Section(acDetail).Height * CLng(MinDetailSections)
    End If
    'Add height of horizontal scroll bar/navigation buttons
    If tFrm.NavigationButtons Or ((tFrm.ScrollBars And 1) = 1) Then
        tFormHeight = tFormHeight + tNavBarHeight
    End If
    On Error Resume Next
    tFormHeight = tFormHeight + tFrm.Section(acHeader).Height + tFrm.Section(acFooter).Height
    On Error GoTo 0
    'Translate form height from twips to pixels (truncate instead of rounding to prevent 1-pixel "growth" of forms)
    pFormHeight = Int(tFormHeight / TwipsPerInch * YPixelsPerInch) + pVBuffer

    'Fit form on screen vertically
    If pFormRect.Bottom >= pAppCanvas.Bottom + pAppRect.Top Or pFormCanvas.Bottom = 0 Then
        KeepFormOnCanvas = True
        If pFormHeight > pFormRect.Bottom - pFormRect.Top Then
            pNewHeight = pFormHeight
        Else
            pNewHeight = pFormRect.Bottom - pFormRect.Top
        End If
        pNewTop = pAppCanvas.Bottom - pNewHeight
    ElseIf pFormRect.Top < pAppRect.Top Then
        'reposition windows to the top of the Access canvas (can only occur with dialog windows)
        KeepFormOnCanvas = True
        pNewTop = pAppRect.Top
        pNewHeight = pFormRect.Bottom - pFormRect.Top
    Else
        pNewTop = pFormRect.Top - pAppRect.Top - (pVAppBuffer / 2)
        pNewHeight = pFormRect.Bottom - pFormRect.Top
    End If

    If pNewLeft < 0 Then pNewLeft = 0
    If pNewTop < 0 Then pNewTop = 0
    If pNewWidth > pAppCanvas.Right Then pNewWidth = pAppCanvas.Right
    If pNewHeight > pAppCanvas.Bottom Then pNewHeight = pAppCanvas.Bottom

    'Move the form only if we need to (prevents minor adjustments due to buffer allowances of forms that are already open)
    If KeepFormOnCanvas Then apiMoveWindow tFrm.hWnd, pNewLeft, pNewTop, pNewWidth, pNewHeight, True


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

Sample Usage

Here's what happens if we call our updated ShowForm() function five times with four different Where clauses:

In the screenshot below, note that the second instance of the form is mostly hidden by the first instance.  That's because we used the same where clause in the first and third lines above.  The second call to ShowForm "frmMSysObjects", "Name='Reports'" caused the first form instance to get the focus and jump on top of the second form instance in the Z order.

Cover image created with Microsoft Designer

UPDATE [2023-07-26]: Added RemoveForm() to actual code (as introduced in Part 2).