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

• ThunderFrame: I'm working from a single-screen laptop, but for multi monitor set-ups (IIRC, Access can get the placement of dialogs wildly off), does this center the dialog in the Access window, or the window of the Access screen, or spanned across the screens? It might be nice to make it user configurable as part of the ShowDialog method, or a property of the dialog. Likewise, a common hack of dialogs is to remove the title bar for a cleaner dialog, but allowing style options on the dialog (such as the appearance of a title bar) would be another nice configuration feature.
• ThunderFrame: Another nice feature might be to replicate the (little? known)Ctrl-C behavior of the MsgBox dialog, whereby the dialog text/options are copied to the clipboard as text. For users that know about the feature, that can make support issues easier to document and communicate, rather than the emailing of screenshots.
• this: RE: screen placement, this iteration tries to make it easy for user to use the existing twips measurements to dictate how it will be placed relevant to Access's MDI area. If 0 is passed in for Left and Top, it should place just at the upper left corner touching the navigation pane and the ribbon, just as standard <form>.Move would have done. I did not really think about multi-monitor support. I believe to avoid this, we'd have to use API exclusively, but then the twips input wouldn't make much sense. User'd need to input different set of measurement.
• this: RE: title bar - yes I did originally want to remove userform's titlebar so that I can use Access form's titlebar & dialogs. However I ran into problems: 1) userform does not have native properties (?) to hide border & titlebar as Access form does. I assume I need API calls. 2) the Access form is made a child of Userform and thus the 0,0 coordinate is always the upper left corner below the Userform's titlebar. So even if I used API calls to change the style of userform, I would need additional codes to handle offsets. I may tackle that in a next iteration.
• AHeyne: How should Me.Showin ShowDialog work? DialogManager has no such member.

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.

• this: RE: compilation constants - In VBA6 hosts, VBA7 doesn't exist so it will be evaluated to false and thus the declares and variables in the Else branch will be used.
• this: RE: rendering limit - yes, that is an issue even with <form>.Move method which the code tries to replicate, so it's still limited by that. Because most Access users are used to setting twips relative to screen, it seemed most compatible. As mentioned in other comment, I may support direct API calls for arbitrary placement. I now realize I didn't consider case where when form opens centered (which usually is the default), and it's already >32000. I should investigate that. Thanks!
• this: Question has been updated to remove the Val for the posterity.
• 200_success: @this Please see What to do when someone answers . I have rolled back Rev 6 → 4.