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.
Multi-instance forms–where you open multiple copies of the same form object–are a powerful but underused feature in Access.
Being able to compare two records side by side makes data analysis much easier.
Keeping multiple instances of the same form open in Access is surprisingly difficult, though. You can't just call DoCmd.OpenForm multiple times. Instead, you need to create new instances of the form's class module (i.e., its code-behind). You also need to ensure those instances don't go out of scope otherwise their associated forms will close.
Even if you can navigate all those challenges, there's a good chance your users won't even realize you've added support for multiple form instances.
That's because every time they open a new instance of the form, it opens the same size and at the same position on the screen. In other words, the forms stack directly on top of each other. Unless the user moves the form, it will look like the new instance is simply replacing the existing instance. This matches the behavior of every other Access form interaction they've had, so they don't even question it.
What we need is a way to make it obvious to the user that we have opened multiple instances of the form.
Prior Art: The Windows Operating System
While this may be a relatively new problem for most Access developers, it's a very common problem in Microsoft Windows.
Most applications–including the cmd console–support multiple instances. If every new cmd console appeared in the same spot on the screen, you wouldn't realize there was more than one. To handle this situation, the Windows team chose to create a "cascading" effect, where subsequent windows would open down and to the right of each earlier window.
Let's see if we can recreate this cascade effect in Microsoft Access.
Sample Usage
For the sample usage, let's look at a BEFORE and AFTER of opening multiple form instances with and without our CascadeForm() routine.
BEFORE
Without incorporating the CascadeForm() function, all four instances of the frmMSysObjects form open directly on top of the others, making it appear as though only a single instance of the form is open:
AFTER
After incorporating the CascadeForm() function into our ShowForm() function, it's now immediately obvious that we have four different instances of the form open at once:
On a side note, customizing the multi-instance form's caption in its Current() event would further enhance the user experience by making it easier to find the desired form instance.
The Approach
The idea is to open each subsequent instance of a form down and to the right of the previous one.
We do this by keeping track of how many instances of a given form are open during the Access session and storing a "Depth" value for that form. When another instance of the form is open, we use the Depth value to shift the form down and to the right.
We continue shifting the forms down and to the right until they no longer fit on the form's "canvas."
When this happens, we reset the Depth value to zero, which forces the next instance of the form to open in the original location. In this way, the forms continue to cascade indefinitely no matter how many form instances are opened.
The Function
Here is the CascadeForm() function on its own without its required dependencies.
' ----------------------------------------------------------------
' 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 SubThe Full Code
The code below includes required helper functions that I've written about in the past:
The code can be copied and pasted into a blank standard module to get a fully-working solution that you can easily integrate into your projects:
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
