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!
In yesterday's article, I shared a function, FillAccessWindow, that I use to automatically resize forms and reports to fill the available space in the Access window. I'm going to stick with that same theme today and share a function that I use to solve a different problem when dealing with "windowed" (i.e., not tabbed) forms.
Forms have an Auto-Center property. That is convenient in some situations, but I don't actually use it that much. For most of my forms, I have that property set to False.
With that property set to False, you can control where your form appears on-screen at runtime by where you save it on-screen at design time. The setting is an offset from the upper left corner of the screen.
Here is an example:
If I close Form1, then open it (DoCmd.OpenForm "Form1"), this is how it appears. Notice that the top left corner is the same as in design mode.
So far, so good. But what happens if the user resizes their Access window so that the form can't open in its entirety where we saved it?
This is almost certainly not what we want to have happen. Wouldn't it be nice if the form would automatically move itself up and to the left if the Access window is too small for it to fit? I think so.
And when I get it in my head that I don't like how something works in Access, I just bang my head against the wall until I make it work. In this case, the result of all that headbanging is a function that I call KeepFormOnCanvas.
KeepFormOnCanvas Forms!Form1
KeepFormOnCanvas to the rescue!The Code
This code is well-tested, but you should always save and backup your work before running Windows API calls for the first time. If you get something wrong when using an API call, there is a good chance Access will hard-crash without giving you a chance to save your work first.
Also, there is no error handling in these routines. That's because I use vbWatchdog. You should, too. But if you don't, you'll probably want to add error handling to the routines that need it.
Option Compare Database
Option Explicit
Private Type rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#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
#If VBA7 Then
Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As LongPtr, lpRect As rect) As Long
#Else
Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As rect) As Long
#End If
#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 GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
#Else
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, _
ByVal hdc As LongPtr) As Long
#Else
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, _
ByVal nIndex As Long) As Long
#Else
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
#End If
Private Const WU_LOGPIXELSX = 88
Private Const WU_LOGPIXELSY = 90
'---------------------------------------------------------------------------------------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
Image by felicerizzo from Pixabay
UPDATE [2023-07-18]: Added function name to the post title.
