Creating dialog with Access form instances

Question

With Access forms, creating a true dialog form -- in the sense of actually pausing execution of the calling VBA code -- with only instances (rather than using global default instances) is a significant challenge. Typically to open a form, one would use this code:

DoCmd.OpenForm FormName:="<some form name>", WindowMode:=acDialog

Which really sucks because we can't pass in an instance, nor can we manage the form that is open, unless we mix in code which creates its own problems.

An userform has the advantage of being able to open in a dialog mode with .Show method, when ShowModal is set to true, and thus using instances is much easier with an userform.

This is an attempt to extend Access forms with the ability to instantiate a dialog by using SetParent to graft Access form on an userform, and using its native methods.

Some issues need to be considered:

1) Who's responsible for closing the dialog?

Logically, the Access form should be the one who gets to decide when it needs to close. To avoid cyclic dependencies, it seems logical that the form should manage the instance of DialogManager if it wants to be opened as a dialog.

2) I feel that IDialog assumes too much from the implementations, especially with ShowDialog, which is not likely to change that much for each implementation.

3) Note the use of CodeContextObject on the HideDialog - the intention is to ensure that only the Access form can decide to close and not some external entity. Is that going overboard?

Any other feedback warmly welcomed!

IDialog Interface

Option Compare Database
Option Explicit

Public Sub ShowDialog()
    'Should create an instance of DialogManager and then invoke ShowDialog passing in itself
End Sub

Public Function MayCloseDialog() As Boolean
    'Should indicate if closing dialog is permissible. Used by DialogManager's QueryClose event
End Function

DialogManager Userform

Option Compare Database
Option Explicit

Private Const ModuleName As String = "Dialog Manager"
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

Private Type POINT
  X As Long
  Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Enum ScreenUOMConversions
    TwipsPerInch = 1440
    PointsPerInch = 72
End Enum

Private Enum hWndInsertAfterFlags
    HWND_BOTTOM = 1 'Places the window at the bottom of the Z order. If the hWnd parameter identifies a topmost window, the window loses its topmost status and is placed at the bottom of all other windows.
    HWND_NOTOPMOST = -2 'Places the window above all non-topmost windows (that is, behind all topmost windows). This flag has no effect if the window is already a non-topmost window.
    HWND_TOP = 0 'Places the window at the top of the Z order.
    HWND_TOPMOST = -1 'Places the window above all non-topmost windows. The window maintains its topmost position even when it is deactivated.
End Enum

Private Enum SetWindowPosFlags
    SWP_ASYNCWINDOWPOS = &H4000 'If the calling thread and the thread that owns the window are attached to different input queues, the system posts the request to the thread that owns the window. This prevents the calling thread from blocking its execution while other threads process the request.
    SWP_DEFERERASE = &H2000 'Prevents generation of the WM_SYNCPAINT message.
    SWP_DRAWFRAME = &H20 'Draws a frame (defined in the window's class description) around the window.
    SWP_FRAMECHANGED = &H20 'Applies new frame styles set using the SetWindowLong function. Sends a WM_NCCALCSIZE message to the window, even if the window's size is not being changed. If this flag is not specified, WM_NCCALCSIZE is sent only when the window's size is being changed.
    SWP_HIDEWINDOW = &H80 'Hides the window.
    SWP_NOACTIVATE = &H10 'Does not activate the window. If this flag is not set, the window is activated and moved to the top of either the topmost or non-topmost group (depending on the setting of the hWndInsertAfter parameter).
    SWP_NOCOPYBITS = &H100 'Discards the entire contents of the client area. If this flag is not specified, the valid contents of the client area are saved and copied back into the client area after the window is sized or repositioned.
    SWP_NOMOVE = &H2  'Retains the current position (ignores X and Y parameters).
    SWP_NOOWNERZORDER = &H200 'Does not change the owner window's position in the Z order.
    SWP_NOREDRAW = &H8  'Does not redraw changes. If this flag is set, no repainting of any kind occurs. This applies to the client area, the nonclient area (including the title bar and scroll bars), and any part of the parent window uncovered as a result of the window being moved. When this flag is set, the application must explicitly invalidate or redraw any parts of the window and parent window that need redrawing.
    SWP_NOREPOSITION = &H200 'Same as the SWP_NOOWNERZORDER flag.
    SWP_NOSENDCHANGING = &H400 'Prevents the window from receiving the WM_WINDOWPOSCHANGING message.
    SWP_NOSIZE = &H1  'Retains the current size (ignores the cx and cy parameters).
    SWP_NOZORDER = &H4 ' Retains the current Z order (ignores the hWndInsertAfter parameter).
    SWP_SHOWWINDOW = &H40 'Displays the window
End Enum

Public Enum DialogManagerErrorCodes
    AlreadyInstantiated = vbObjectError + &H1
    MustImplementIDialog = vbObjectError + &H2
    IncorrectStyling = vbObjectError + &H3
    NotAPopUpForm = vbObjectError + &H4
End Enum

#If VBA7 Then

Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String _
) As LongPtr

Private Declare PtrSafe Function SetParent Lib "user32.dll" ( _
    ByVal hWndChild As LongPtr, _
    ByVal hWndNewParent As LongPtr _
) As LongPtr

Private Declare PtrSafe Function GetClientRect Lib "user32.dll" ( _
    ByVal hWnd As LongPtr, _
    ByRef lpRect As RECT _
) As Boolean

Private Declare PtrSafe Function GetWindowRect Lib "user32.dll" ( _
    ByVal hWnd As LongPtr, _
    ByRef lpRect As RECT _
) As Boolean

Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" ( _
    ByVal hWnd As LongPtr, _
    ByVal hWndInsertAfter As LongPtr, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal uFlags As SetWindowPosFlags _
) As Boolean

Private Declare PtrSafe Function EnableWindow Lib "user32.dll" ( _
    ByVal hWnd As LongPtr, _
    ByVal bEnable As Boolean _
) As Boolean

Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
  ByRef lpPoint As POINT _
) As Boolean

Private Declare PtrSafe Function GetDC Lib "user32" ( _
  ByVal hWnd As LongPtr _
) As LongPtr

Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hDC As LongPtr, _
  ByVal nIndex As Long _
) As Long

Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _
  ByVal hWnd As LongPtr, _
  ByVal hDC As LongPtr _
) As Long

#Else

Private Declare Function FindWindowA Lib "user32.dll" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String _
) As Long

Private Declare Function SetParent Lib "user32.dll" ( _
    ByVal hWndChild As Long, _
    ByVal hWndNewParent As Long _
) As Long

Private Declare Function GetClientRect Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByRef lpRect As RECT _
) As Boolean

Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByRef lpRect As RECT _
) As Boolean

Private Declare Function SetWindowPos Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal uFlags As SetWindowPosFlags _
) As Boolean

Private Declare Function EnableWindow Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal bEnable As Boolean _
) As Boolean

Private Declare Function GetCursorPos Lib "user32" ( _
  ByRef lpPoint As POINT _
) As Boolean

Private Declare Function GetDC Lib "user32" ( _
  ByVal hWnd As Long _
) As LongPtr

Private Declare Function GetDeviceCaps Lib "gdi32" ( _
  ByVal hDC As Long, _
  ByVal nIndex As Long _
) As Long

Private Declare Function ReleaseDC Lib "user32" ( _
  ByVal hWnd As Long, _
  ByVal hDC As Long _
) As Long

#End If

Private Type T
#If VBA7 Then
    UserFormhWnd As LongPtr
    OriginalParenthWnd As LongPtr
#Else
    UserFormhWnd As Long
    OriginalParenthWnd As Long
#End If
    Dialog As IDialog
End Type
Private This As T

Private WithEvents ChildForm As Access.Form

#If VBA7 Then
Public Property Get hWnd() As LongPtr
#Else
Public Property Get hWnd() As Long
#End If
    hWnd = This.UserFormhWnd
End Property

Public Sub ShowDialog(SourceForm As Access.Form)
    Const EventProcedure As String = "[Event Procedure]"

    Select Case True
        Case Not ChildForm Is Nothing
            Err.Raise DialogManagerErrorCodes.AlreadyInstantiated, ModuleName, GetErrorMessage(DialogManagerErrorCodes.AlreadyInstantiated)
        Case Not (TypeOf SourceForm Is IDialog)
            Err.Raise DialogManagerErrorCodes.MustImplementIDialog, ModuleName, GetErrorMessage(DialogManagerErrorCodes.MustImplementIDialog)
        Case Not (SourceForm.BorderStyle = 0)
            Err.Raise DialogManagerErrorCodes.IncorrectStyling, ModuleName, GetErrorMessage(DialogManagerErrorCodes.IncorrectStyling)
        Case SourceForm.PopUp = False
            Err.Raise DialogManagerErrorCodes.NotAPopUpForm, ModuleName, GetErrorMessage(DialogManagerErrorCodes.NotAPopUpForm)
        Case Else
            Set ChildForm = SourceForm
            Set This.Dialog = ChildForm
            ChildForm.OnClose = EventProcedure
            ChildForm.OnResize = EventProcedure
            Me.Show

            'IMPORTANT! Not setting visible to false for the ChildForm could lock up the application
            If Not ChildForm Is Nothing Then
                ChildForm.Visible = False
            End If
    End Select
End Sub

Public Sub HideDialog()
    If CodeContextObject Is ChildForm Then
        Me.Hide
    End If
End Sub

Public Sub MoveOrResize( _
    Left As Integer, _
    Optional Top As Integer, _
    Optional Width As Integer, _
    Optional Height As Integer _
)
    Dim AppRect As RECT
    Dim AccessFormRect As RECT
    Dim UserFormRect As RECT
    Dim AppOffset As POINT      'Offset between the Access Application and the Access form
    Dim DialogOffset As POINT   'Offset between the UserForm and the Access Form

    GetWindowRect Application.hWndAccessApp, AppRect
    GetWindowRect ChildForm.hWnd, AccessFormRect
    GetWindowRect This.UserFormhWnd, UserFormRect

    AppOffset = UOMFromPixels(TwipsPerInch, AccessFormRect.Left - AppRect.Left, AccessFormRect.Top - AppRect.Top)
    AppOffset.X = AppOffset.X - ChildForm.WindowLeft
    AppOffset.Y = AppOffset.Y - ChildForm.WindowTop

    DialogOffset = UOMFromPixels(TwipsPerInch, AccessFormRect.Left - UserFormRect.Left, AccessFormRect.Top - UserFormRect.Top)
    DialogOffset.X = DialogOffset.X - AppOffset.X
    DialogOffset.Y = DialogOffset.Y - AppOffset.Y
    Me.Move UOMToUOM(TwipsPerInch, (Left - DialogOffset.X), PointsPerInch), UOMToUOM(TwipsPerInch, (Top - DialogOffset.Y), PointsPerInch), UOMToUOM(TwipsPerInch, Width, PointsPerInch), UOMToUOM(TwipsPerInch, Height, PointsPerInch)
End Sub

Private Sub ChildForm_Close()
    Set ChildForm = Nothing
End Sub

Private Sub UserForm_Initialize()
    StorehWnd
End Sub

Private Sub StorehWnd()
    Dim WindowCaption As String
    Dim WindowClass As String

    'class name changed in Office 2000
    If Val(Application.Version) >= 9 Then
        WindowClass = "ThunderDFrame"
    Else
        WindowClass = "ThunderXFrame"
    End If

    'remember the caption so we can
    'restore it when we're done
    WindowCaption = Me.Caption

    'give the userform a random
    'unique caption so we can reliably
    'get a handle to its window
    Randomize
    Me.Caption = CStr(Rnd) & CStr(Timer)

    'store the handle so we can use
    'it for the userform's lifetime
    This.UserFormhWnd = FindWindowA(WindowClass, Me.Caption)

    'set the caption back again
    Me.Caption = WindowCaption
End Sub

Private Sub UserForm_Activate()
    Dim OriginalLeft As Integer
    Dim OriginalTop As Integer
    Dim OriginalWidth As Integer
    Dim OriginalHeight As Integer

    OriginalLeft = ChildForm.WindowLeft
    OriginalTop = ChildForm.WindowTop
    OriginalWidth = ChildForm.WindowWidth + 240
    OriginalHeight = ChildForm.WindowHeight + 480

    If Len(ChildForm.Caption) Then
        Me.Caption = ChildForm.Caption
    Else
        Me.Caption = "Dialog"
    End If

    This.OriginalParenthWnd = SetParent(ChildForm.hWnd, This.UserFormhWnd)
    EnableWindow ChildForm.hWnd, True
    ResizeChildForm 'Necessary to avoid weird placements when moving/resizing
    MoveOrResize OriginalLeft, OriginalTop, OriginalWidth, OriginalHeight
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If Not ChildForm Is Nothing Then
        If ChildForm.Visible Then
            Cancel = Not This.Dialog.MayCloseDialog
        End If
    End If
End Sub

Private Sub UserForm_Resize()
    ResizeChildForm
End Sub

Private Sub ResizeChildForm()
    Dim ClientRect As RECT

    ChildForm.SetFocus  'Necessary to remain visible after resizing
    If GetClientRect(This.UserFormhWnd, ClientRect) Then
        SetWindowPos ChildForm.hWnd, HWND_TOP, ClientRect.Left, ClientRect.Top, ClientRect.Right - ClientRect.Left, ClientRect.Bottom, SWP_NOZORDER
    End If
End Sub

Private Sub ResizeUserForm()
    Dim r As RECT
    If GetClientRect(ChildForm.hWnd, r) Then
        SetWindowPos Me.hWnd, HWND_TOP, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, SWP_NOZORDER
    End If
End Sub

Private Function GetErrorMessage(ErrorCode As DialogManagerErrorCodes) As String
    Select Case ErrorCode
        Case DialogManagerErrorCodes.AlreadyInstantiated
            GetErrorMessage = "The dialog is already instantiated with an Access form and cannot be used for another form. Create new instances"
        Case DialogManagerErrorCodes.MustImplementIDialog
            GetErrorMessage = "The specified form does not implement IDialog interface which is required for use with Dialog Manager class."
        Case DialogManagerErrorCodes.IncorrectStyling
            GetErrorMessage = "The form's border must be set to 'None' (0)."
        Case DialogManagerErrorCodes.NotAPopUpForm
            GetErrorMessage = "The form must have its 'Popup' property set to true to be use as a dialog."
    End Select
End Function

Private Sub UserForm_Terminate()
    Set ChildForm = Nothing
    Set This.Dialog = Nothing
End Sub

Private Function UOMFromPixels( _
    ByVal UOM As ScreenUOMConversions, _
    ByVal X As Long, _
    ByVal Y As Long _
) As POINT
#If VBA7 Then
    Dim ScreenDC As LongPtr
#Else
    Dim ScreenDC As Long
#End If
    ScreenDC = GetDC(0)
    UOMFromPixels.X = X / GetDeviceCaps(ScreenDC, LOGPIXELSX) * UOM
    UOMFromPixels.Y = Y / GetDeviceCaps(ScreenDC, LOGPIXELSY) * UOM
    ReleaseDC 0, ScreenDC
End Function

Private Function UOMToPixels( _
    ByVal UOM As ScreenUOMConversions, _
    ByVal X As Long, _
    ByVal Y As Long _
) As POINT
#If VBA7 Then
    Dim ScreenDC As LongPtr
#Else
    Dim ScreenDC As Long
#End If
    ScreenDC = GetDC(0)
    UOMToPixels.X = X / UOM * GetDeviceCaps(ScreenDC, LOGPIXELSX)
    UOMToPixels.Y = Y / UOM * GetDeviceCaps(ScreenDC, LOGPIXELSY)
    ReleaseDC 0, ScreenDC
End Function

Private Function UOMToUOM( _
    InUOM As ScreenUOMConversions, _
    InValue As Variant, _
    OutUOM As ScreenUOMConversions _
) As Variant
    UOMToUOM = ((CDec(InValue) / CDec(InUOM)) * (CDec(OutUOM) / CDec(1)))
End Function

Example implementation in Form_Test

Option Compare Database
Option Explicit

Implements IDialog

Private Dialog As DialogManager

Private Sub Command0_Click()
    Dialog.HideDialog
End Sub

Private Function IDialog_MayCloseDialog() As Boolean
    IDialog_MayCloseDialog = True
End Function

Public Sub IDialog_ShowDialog()
    Set Dialog = New DialogManager
    Dialog.ShowDialog Me
    Set Dialog = Nothing
End Sub

Example calling code to open an instance of Form_Test as a dialog

Public Sub TestDialog()
    Dim f As IDialog

    Set f = New Form_Test
    f.ShowDialog
End Sub

Answer 1

Using `Val`

The Val function can run into problems when converting string values, depending upon the locale of the user. It is generally safer to use CDbl, but it will depend on the input. See Internationalization Tips

Indenting/Line spacing

Your compiler directives follow on the immediate line after the function signatures, which looks a little cluttered, and hard to spot the beginning/end of the compiler directive. I'd like to see an extra line before and after the compiler directives.

Enum ordering

I'll let you off the hook for the inconsistent casing of enum members, as I see that you're trying to implement a consistent style, but also trying to maintain the Win32 capitalizations. But, you are using inconsistent ordering of the enum members - sometimes the members are alphabetical, and sometimes they're by hex value. In my experience, it is better to define the enum in hexagonal order (as it's easier to spot omissions), and then rely on the Object Browser/Intellisense to render the enum members alphabetically.

Magic Numbers/Constants

There are numerous references to magic numbers (like 9 for Office 2000) and string-literals (like "ThunderDFrame") throughout the code. These would be much better defined as constants (with a view to allowing multi-language support). You make the effort on occasion, but not on others. You also use magic numbers like 240 and 480 (for x and y), but without adding comments (or descriptive constant names) to explain why.

Passing 0 to GetDC

Your GetDC function accepts a Long/LongPtr, but you're passing a integer-literal of 0. You can avoid an implicit conversion, by using GetDC(0&) instead of GetDC(0)

Backward Portability

It seems this would almost work in VBA6 hosts, but the VBA7 compiler constant wouldn't be present. For portability, it might be nice to add a commented-out compiler constant of:

'Uncomment the next line for the code to work in VBA6 hosts
'#Const VBA7 = False

Or maybe the non-existent compiler constant would convert to 0, and thereby False, by default?

The Access rendering "32000" limit

Access can run into difficulty on large/multi-monitor systems, where the host window equates to roughly 32000 ( the exact limit seems related to the 32000 give or take the borders imposed by various operating system versions) in the X direction. This is, in my understanding, party an Access limitation, and partly a factor of the way that forms are serialized. You may want to check the behavior when an Access window is wider than a typical 1080p monitor (16x 1920 pixels across), or you may get some unexpected problems.