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!
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
Option Compare Database Option Explicit Private Const ModuleName As String = "Dialog Manager" Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type 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 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 SetWindowPos Lib "user32.dll" ( _ ByVal hWnd As LongPtr, _ ByVal hWndInsertAfter As hWndInsertAfterFlags, _ 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 #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 SetWindowPos Lib "user32.dll" ( _ ByVal hWnd As Long, _ ByVal hWndInsertAfter As hWndInsertAfterFlags, _ 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 #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 Else Set ChildForm = SourceForm Set This.Dialog = ChildForm ChildForm.OnClose = EventProcedure Me.Show End Select End Sub Public Sub HideDialog() If CodeContextObject Is ChildForm Then Me.Hide End If End Sub Private Sub ChildForm_Close() Unload Me 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() 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 End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Cancel = This.Dialog.MayCloseDialog 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 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." End Select End Function
Example implementation in
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 End Sub
Example calling code to open an instance of
Form_frmTest as a dialog
Public Sub TestDialog() Dim f As IDialog Set f = New Form_Test f.ShowDialog End Sub
✓ Extra quality
ExtraProxies brings the best proxy quality for you with our private and reliable proxies
✓ Extra anonymity
Top level of anonymity and 100% safe proxies – this is what you get with every proxy package
✓ Extra speed
1,ooo mb/s proxy servers speed – we are way better than others – just enjoy our proxies!
USA proxy location
We offer premium quality USA private proxies – the most essential proxies you can ever want from USA
Our proxies have TOP level of anonymity + Elite quality, so you are always safe and secure with your proxies
Use your proxies as much as you want – we have no limits for data transfer and bandwidth, unlimited usage!
Superb fast proxy servers with 1,000 mb/s speed – sit back and enjoy your lightning fast private proxies!
99,9% servers uptime
Alive and working proxies all the time – we are taking care of our servers so you can use them without any problems
No usage restrictions
You have freedom to use your proxies with every software, browser or website you want without restrictions
Perfect for SEO
We are 100% friendly with all SEO tasks as well as internet marketing – feel the power with our proxies
Buy more proxies and get better price – we offer various proxy packages with great deals and discounts
We are working 24/7 to bring the best proxy experience for you – we are glad to help and assist you!