Evolution of a Function: ShowForm() Part 3
As our ShowForm function continues to evolve, we begin refactoring and addressing several shortcomings of our earlier efforts.
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
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 IfThis 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_ShowFormCascading 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().
Mike 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 IfIf 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_ShowFormEnsure 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 FrmSee the article below for details and example screenshots.
Mike 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
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 FunctionSample 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).
