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!

Get Back Here, Form!

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:

Form1 in Design View

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.

Form1 in Form View

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?

Form1 in Form View - Access application window is too small

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

Comments

Sign in or become a No Longer Set member to join the conversation.
Just enter your email below to get a log in link. (This will also subscribe you to my weekly newsletter.)