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:
- Easier ongoing maintenance
- More scalable
- Easier to track which form object to open
- 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
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().
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.
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
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
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
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
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).