Fun with Form Windows

Using my FillAccessWindow function to resize Form and Report objects relative to the amount of available space on the Access canvas.

Fun with Form Windows

Several versions back, Microsoft Access introduced a feature that supports tabbed interfaces where every form, datasheet, and report are opened full-screen.  I have to confess, I never spent a lot of time with that feature, so I may be missing out.  But, if you still use the "old school" windowed forms like me, then boy have I got a treat for you today.

I wrote a function named FillAccessWindow that resizes Form and Report objects relative to the amount of available space on the Access canvas.  Allow me to demonstrate.

Default form opening behavior

The form opens at the same size and location (relative to the upper left corner of the screen) as the last time it was saved in Design View.  If the form is too big to fit on the canvas, the Access window gets scrollbars and you have to scroll the window to see the form.

DoCmd.OpenForm "Form1"

Forcing a form to Maximized after opening

I used to force reports to Maximized when I opened them in preview mode.  The problem came when the user closed the report.  The form that received the focus after a maximized report closed became maximized itself.  This was not usually what I wanted.  To work around this behavior, I would save the state of the form prior to opening the report.  Then, when the user closed the maximized report, I would restore the form to whatever its original state was.  This worked well most of the time, but it was never perfect.

DoCmd.OpenForm "Form1": DoCmd.Maximize

Filling the available space without maximizing the form

This is what I do now when I preview reports.  Rather than maximizing the report itself, I simply resize it to fill the available space.  I'm using forms for all the screenshots in this article, but the function works the same with reports.

'Fill the available space without maximizing
DoCmd.OpenForm "Form1":FillAccessWindow

Why stop there?

Once I had worked out all the necessary API calls to achieve the above behavior, I realized I could support a bunch of extra functionality without much more work.  For example, what if we had four forms (or reports) that we wanted to display at the same time?

'Divide the canvas into quadrants; populate clockwise
DoCmd.OpenForm "Form1":FillAccessWindow , ,"NW", .5, .5
DoCmd.OpenForm "Form2":FillAccessWindow , ,"NE", .5, .5
DoCmd.OpenForm "Form3":FillAccessWindow , ,"SE", .5, .5
DoCmd.OpenForm "Form4":FillAccessWindow , ,"SW", .5, .5

How about a sidebar?

'Create a sidebar with stacked forms in the remaining space
DoCmd.OpenForm "Form1":FillAccessWindow , ,"NW", 1, .4
DoCmd.OpenForm "Form2":FillAccessWindow , ,"NE", .5, .6
DoCmd.OpenForm "Form3":FillAccessWindow , ,"SE", .5, .6

Filling available space while maintaining an aspect ratio

'Fill the available space but maintain a specific aspect ratio

'1:1 aspect ratio (i.e., square)
DoCmd.OpenForm "Form1":FillAccessWindow , 1, "Center"  

'1:2 (height to width; landscape)
DoCmd.OpenForm "Form2":FillAccessWindow , .5, "Center" 

'7:4 (height to width; portrait)
DoCmd.OpenForm "Form3":FillAccessWindow , 1.75, "Center"  

The Code

Without further ado, here is the code.  This is pretty rock solid code, 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 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 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

'----------------------------------------------------
' Procedure : FillAccessWindow
' Author    : Mike Wolfe <mike@nolongerset.com>
'
'Used to set the window size of an Access form or report
'Usage A: Fill the available screen space
'   FillAccessWindow Frm.Hwnd
'
'Usage B: Maximize the form or report while maintaining a given ratio (a square in this example)
'   FillAccessWindow Frm.Hwnd, 1
'
'Usage C: A tall window anchored to the upper right corner of available space
'   FillAccessWindow Frm.Hwnd, 2.5, "NE"
'
'Usage D: Arrange four forms to fill the corners of the available space
'   FillAccessWindow FrmA.Hwnd, , "NW", 0.5, 0.5
'   FillAccessWindow FrmB.Hwnd, , "NE", 0.5, 0.5
'   FillAccessWindow FrmC.Hwnd, , "SE", 0.5, 0.5
'   FillAccessWindow FrmD.Hwnd, , "SW", 0.5, 0.5
'
Sub FillAccessWindow(Optional ChildHWnd As Long, _
    Optional HtToWdRatio As Double = 0, _
    Optional AnchorLoc As String = "NW", _
    Optional HeightToCanvasRatio As Double = 1, _
    Optional WidthToCanvasRatio As Double = 1)

    
    Dim hWnd As Long, Canvas As rect
    hWnd = GetHWnd(ChildHWnd)
    Canvas = GetCanvas(hWnd)
    
    Dim wd As Long, ht As Long
    wd = (Canvas.Right - Canvas.Left) * WidthToCanvasRatio
    ht = (Canvas.Bottom - Canvas.Top) * HeightToCanvasRatio
   
   'Handle the case where we want to maintain a specific Height-to-Width ratio
    If HtToWdRatio <> 0 Then
        Dim CanvasHtToWdRatio As Double
        CanvasHtToWdRatio = (Canvas.Bottom - Canvas.Top) / (Canvas.Right - Canvas.Left)
        If CanvasHtToWdRatio > HtToWdRatio Then
            ht = wd * HtToWdRatio
        Else
            wd = ht / HtToWdRatio
        End If
    End If

    'Move and resize the window
    Select Case AnchorLoc
        Case "Center"
            apiMoveWindow hWnd, (Canvas.Right - wd) / 2, (Canvas.Bottom - ht) / 2, wd, ht, True
        Case "NE"
            apiMoveWindow hWnd, Canvas.Right - wd, 0, wd, ht, True
        Case "SE"
            apiMoveWindow hWnd, Canvas.Right - wd, Canvas.Bottom - ht, wd, ht, True
        Case "SW"
            apiMoveWindow hWnd, 0, Canvas.Bottom - ht, wd, ht, True
        Case Else '"NW"
            apiMoveWindow hWnd, 0, 0, wd, ht, True
    End Select
End Sub

'Returns HWnd if <> 0, else the window handle of the active on-screen object
Private Function GetHWnd(hWnd As Long) As Long
    On Error Resume Next
    GetHWnd = hWnd
    If GetHWnd = 0 Then GetHWnd = Screen.ActiveForm.hWnd
    If GetHWnd = 0 Then GetHWnd = Screen.ActiveReport.hWnd
    If GetHWnd = 0 Then GetHWnd = Screen.ActiveDatasheet.hWnd
End Function

Function GetCanvas(Optional ByVal ChildHWnd As Long) As rect
    Dim CanvasHwnd As Long
    CanvasHwnd = GetInnerAccessHwnd(ChildHWnd)
    apiGetClientRect CanvasHwnd, GetCanvas
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 Free-Photos from Pixabay

All original code samples by Mike Wolfe are licensed under CC BY 4.0