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
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. \$\endgroup\$Left
andTop
, 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. \$\endgroup\$Me.Show
inShowDialog
work?DialogManager
has no such member. \$\endgroup\$