Yes, even 10 years in, SDI is still frustrating XLAM devs... I too saw the 'vanishing' userform and ended up using APIs to make this work. Even with those, there are some edge cases that needed consideration:
- The use of SetParent works well to a degree, and the issue appears to be about userform positioning. Setting both .left and .top (in VBA) for a userform isn't reliable when the userform is passed in to a subroutine as an object. Setting one or the other seemed ok, but in any case, the coordinate systems aren't what was expected. This was dealt with using the SetWindowPos API in positionUserForm().
- A second monitor complicates things wrt form position. Even when using the SetWindowPos API call, the userform vanished when the initial calling window was on a secondary monitor. This was dealt with by detecting the current monitor for the active window when loading the form the first time, moving the window to the primary monitor, loading the form, and then moving the active window back to its original position. Additionally, if the excel window is maximized on a second monitor, the winState must be set to xlNormal before moving it. The moving of the window creates a visible blip, but only when launching from a second monitor, thanks to isWindowOnPrimaryMonitor().
- The modeless userform itself changes (for the better) after setParent. Prior to calling setParent (through the winActivate event), the modeless form sat on top of all Excel windows, after setParent it sat inside the activeWindow. This 'first use' edge case was dealt with by calling SetParent just before .Show in ShowModeless.
Only tested w/ 32bit...Hope this gets you home.
'''' Class WinActivate
Public WithEvents AppEvents As Application
Private Sub AppEvents_WindowActivate(ByVal wb As Workbook, ByVal wn As Window)
'Change precedent object of UserForm when switching windows
'hwndUserForm is a global that is set when a userform is loaded and set to 0 when it's unloaded
If Val(Application.Version) >= 15 And hwndUserForm <> 0 Then
SetParent hwndUserForm, wn.hWnd
positionUserForm objUserForm, wn.hWnd
End If
End Sub
''''Standard Module
Option Explicit
#If Win64 Then
Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
Private Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" (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 wFlags As Long) As Long
'Unsure of these 64bit declations :EnumDisplayMonitors, GetMonitorInfo, MonitorFromWindow
Private Declare PtrSafe Function EnumDisplayMonitors Lib "user32.dll" (ByVal hdc As LongPtr, ByRef lprcClip As Any, ByVal lpfnEnum As LongPtr, ByVal dwData As LongPtr) As Boolean
Private Declare PtrSafe Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As LongPtr, ByRef lpmi As MonitorInfoEx) As Boolean
Private Declare PtrSafe Function MonitorFromWindow Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal dwFlags As LongPtr) As LongLong
''''''''
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
#ElseIf Win32 Then
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "user32" (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 wFlags As Long) As Long
Private Declare Function EnumDisplayMonitors Lib "user32.dll" (ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As Long, ByVal dwData As Long) As Boolean
Private Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As MonitorInfoEx) As Boolean
Private Declare Function MonitorFromWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
#End If
'support SetWindowPos
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
'support finding the primary monitor
Public Const CCHDEVICENAME = 32
Public Const MONITORINFOF_PRIMARY = &H1
'RECT anmd MonitorInfoEx, may need to be conditionally included for 64bit
'only tested on 32 bit Excel versions
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type MonitorInfoEx
cbSize As Long
rcMonitor As RECT
rcWork As RECT
dwFlags As Long
szDevice As String * CCHDEVICENAME
End Type
Dim MonitorId() As String
'references to modal userForm and var for window switching
Dim WA As New WinActivate
Public hwndUserForm As Long
Public objUserForm As Object
Sub ShowModeless()
Set WA.AppEvents = Application
SetParent hwndUserForm, ActiveWindow.hWnd
objUserForm.Show vbModeless
End Sub
Sub load_test_form()
'the form has to be created on a window that's on the primary monitor
' for it to show consistently. So stash the left coord in case you need it
Dim startLeft As Integer
Dim wnState As Long
Dim isPrimaryMonitor As Boolean
startLeft = ActiveWindow.Left
wnState = ActiveWindow.WindowState 'in case it's maximized on a secondary monitor and needs to be moved
isPrimaryMonitor = isWindowOnPrimaryMonitor(ActiveWindow)
If Not isPrimaryMonitor Then
Dim xLeft As Long
Dim yTop As Long
'move the activewindow to the primary monitor (must be in normal state)
getPrimaryMonitorInfo xLeft, yTop
ActiveWindow.WindowState = xlNormal
ActiveWindow.Left = xLeft
End If
'load the form
Load frm_test
Set objUserForm = frm_test
hwndUserForm = FindWindow("ThunderDFrame", objUserForm.Caption)
positionUserForm objUserForm, ActiveWindow.hWnd
ShowModeless
'reset the left and state in case it was changed
If Not isPrimaryMonitor Then
ActiveWindow.WindowState = xlNormal
ActiveWindow.Left = startLeft
ActiveWindow.WindowState = wnState
End If
End Sub
Public Sub positionUserForm(ByRef thisform As Object, ByVal parentHwnd)
If thisform Is Nothing Then Exit Sub
thisform.StartUpPosition = 0
Dim xPos As Integer
Dim yPos As Integer
yPos = ActiveWindow.Top + (ActiveWindow.Height - thisform.Height) / 2
xPos = ActiveWindow.Left + (ActiveWindow.Width - thisform.Width) / 2
SetWindowPos hwndUserForm, ActiveWindow.hWnd, xPos, yPos, 0, 0, SWP_NOSIZE 'Or HWND_TOPMOST
End Sub
Public Function isWindowOnPrimaryMonitor(ByRef wn As Window) As Boolean
'returns true if the window passed in is on the primary monitor
Dim hMonitor As Long
Dim apiReturnCode As Long
Dim MonitorInfoEx As MonitorInfoEx
MonitorInfoEx.cbSize = Len(MonitorInfoEx)
hMonitor = MonitorFromWindow(wn.hWnd, &H0&)
'MonitorInfo.cbSize = LenB(MonitorInfo)
apiReturnCode = GetMonitorInfo(hMonitor, MonitorInfoEx)
If MonitorInfoEx.dwFlags And MONITORINFOF_PRIMARY Then
isWindowOnPrimaryMonitor = True
Else
isWindowOnPrimaryMonitor = False
End If
End Function
Private Sub getPrimaryMonitorInfo(xLeft As Long, yTop As Long)
Dim i As Integer
GetMonitorId 'get all the monitor handles
Dim MonitorInfoEx As MonitorInfoEx
MonitorInfoEx.cbSize = Len(MonitorInfoEx)
For i = 1 To UBound(MonitorId)
GetMonitorInfo CLng(MonitorId(i)), MonitorInfoEx
With MonitorInfoEx
If .dwFlags And MONITORINFOF_PRIMARY Then
With .rcMonitor
xLeft = MonitorInfoEx.rcMonitor.Left
yTop = MonitorInfoEx.rcMonitor.Top
End With
Exit For
End If
End With
Next i
End Sub
Public Function GetMonitorId()
'populates the monitor array ids
ReDim MonitorId(0)
EnumDisplayMonitors &H0, ByVal &H0, AddressOf MonitorEnumProc, &H0
GetMonitorId = UBound(MonitorId)
End Function
Public Function MonitorEnumProc(ByVal hMonitor As Long, ByVal hdcMonitor As Long, ByRef lprcMonitor As RECT, ByVal dwData As Long) As Boolean
Dim ub As Integer
ub = 0
On Error Resume Next
ub = UBound(MonitorId)
On Error GoTo 0
ReDim Preserve MonitorId(ub + 1)
MonitorId(UBound(MonitorId)) = CStr(hMonitor)
MonitorEnumProc = 1
End Function
