Listening to the UserForm_Activate event using WithEvents in a Class Module.

[Jaafar Tribak]

Hi,

Say for example, you have a couple of modeless userforms on display and you want to run some small macro each time you activate each userform.

The obvious answer is simply placing the small macro (or a call to it) in each of the UserForm_Activate event handlers.

But what If you wanted to have a common event handler in a class module that runs the common code (similar to what we do with form controls) ?

If you try using Private WithEvents uFormEVents As UserForm, you will find that the Actiavate\Deactivate events are not exposed by the class.

Yes. I have come up with some workarounds like subclassing the userforms ( and catching the WM_NCACTIVATE ) or using a windows timer to detect when the userforms are being activated but I am trying to avoid such approaches as they are both risky and have a heavy performance hit. I am looking for a more OOP oriented approach.

Does anyone have any suggestions ?

The subject of this recent thread is what prompted me to post this question.

 

[sijpie]

Hi Jaafar,
Yes it is a real pain, that VBA does not have full object oriented inheritance. Even with textboxes etc some of the events are not possible when trying to make a class for them.

No, I don't have a better solution. I never tried this either for userforms, just for controls.

 

[Jaafar Tribak]

@sijpie Thanks for the interest.

I have a draft code almost finsished that I have abandoned. The code is supposed to allow the user to move various userforms simultaneously.

Unfortunately, the code uses a windows timer needed for dynamically detecting the current active userform. It doesn't use the UserForm_Activate event as I had wished.

I will probably finish putting the final touches on the almost finished draft code and post the final result here for future reference in case anyone is interested.

 

[Jaafar Tribak]

Ok- I just got around to finsishing this over the weekend.

Although the code uses a Class to manage the group of userforms (Trying to make this as OOP as possible), and despite the fact that the userforms move synchronously very smoothly, The overall code design is amiss since it has the following issues:

1- The CGroup Class exposes Public Methods that shouldn't be seen\used by client code. I could have worked around this limitation using an extra Interface Class but I prefered to keep everything in a single class.
2- The FormsCollection doesn't work as one would expect.
3- We can create only one group at a time.

Furthermore, I couldn't make this work without using a windows timer. (Although accidental runtime errors are taken care of)

Workbook Example





1- CGroup Class:

Option Explicit

Public FormsCollection As Collection
Private WithEvents UfEvents As MSForms.UserForm

Private Sub Class_Initialize()
    If bExecuting = False Then
        Set FormsCollection = New Collection
    End If
End Sub

Private Sub Class_Terminate()
    Set FormsCollection = Nothing
    Debug.Print "Term"
End Sub

Public Sub AddForm(ByVal Frm As Object, Optional ByVal Gap As Long)
    Call Add(Frm, Gap)
End Sub

Public Sub Execute()
    Call ExecuteProc(Me)
End Sub

Public Function FormsCount() As Long
    FormsCount = GetFormsCount
End Function

Public Sub Z_DO_NOT_USE_THIS_METHOD_ADD_TO_FORMS_COLLECTION(Frm As Object)
    FormsCollection.Add Frm
End Sub

Public Function Z_DO_NOT_USE_THIS_METHOD_ACTIVE_FORM() As Object
    Set Z_DO_NOT_USE_THIS_METHOD_ACTIVE_FORM = GetTheActiveForm
End Function

Public Sub Z_DO_NOT_USE_THIS_METHOD_HOOK_FORM(Frm As Object)
    Set UfEvents = Frm
End Sub

Private Sub UfEvents_Layout()
    Call MoveProc
End Sub

2- API_bas code (Standard Module)

Option Explicit
Option Private Module

Private Type POINTAPI
    X As Long
    y As Long
End Type

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

Private Type GUID
    lData1 As Long
    iData2 As Integer
    iData3 As Integer
    iData4(0 To 7) As Byte
End Type


#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    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
    Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
    Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function IIDFromString2 Lib "ole32.dll" Alias "IIDFromString" (ByVal lpsz As LongPtr, lpiid As GUID) As LongPtr
    Private Declare PtrSafe Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hUf As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hUf As LongPtr, ByVal nIDEvent As LongPtr) As Long

     Private hContainer As LongPtr, hLastActiveForm As LongPtr
#Else
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) 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 SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Sub ReleaseCapture Lib "user32" ()
    Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As Any, ByVal wParam As Long, ppvObject As Any) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    Private Declare Function IIDFromString2 Lib "ole32.dll" Alias "IIDFromString" (ByVal lpsz As Long, lpiid As GUID) As Long
    Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hUf As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hUf As Long, ByVal nIDEvent As Long) As Long

    Private hContainer As Long, hLastActiveForm As Long
#End If

Public bExecuting As Boolean
Private bFormClosed As Boolean
Private oGroupsCollection As Collection
Private oFirstGroupInstance As CGroup
Private W As Double, H As Double
Private lPrevChildCount As Long


'__________________________________PUBLIC ROUTINES______________________________________________

Public Sub Add(Frm As Object, Optional ByVal Gap As Long)

    If bExecuting Then
        Exit Sub
    End If
    
    With Frm
        .StartUpPosition = 0
        .Tag = "frm*" & W
        If Gap < 0 Then Gap = 0
        W = W + .Width + Gap
        H = IIf(.Height > H, .Height, H)
    End With
    
    Call BuildFormConaitner

End Sub

Public Sub ExecuteProc(FirstGroupInstance As CGroup)

    Const SWP_NOSIZE = &H1
    Const SWP_SHOWWINDOW = &H40
    
    #If Win64 Then
        Dim hFrm As LongLong
    #Else
        Dim hFrm As Long
    #End If
    
    Dim oCGroup As CGroup
    Dim oFrm As Object
    Dim lLeft As Long
    
    If bExecuting Then
        Set FirstGroupInstance.FormsCollection = oFirstGroupInstance.FormsCollection
        Call RebuildFormsCollection
        Exit Sub
    End If
    
    bExecuting = True
    Set oFirstGroupInstance = FirstGroupInstance
    Set FirstGroupInstance = Nothing
    
    For Each oFrm In VBA.UserForms
        If Left(oFrm.Tag, 3) = "frm" Then
            lLeft = PTtoPX(CDbl(Split(oFrm.Tag, "*")(1)), False)
            Call IUnknown_GetWindow(oFrm, VarPtr(hFrm))
            Call SetParent(hFrm, hContainer)
            Call SetWindowPos(hFrm, 0, lLeft, 0, 0, 0, SWP_SHOWWINDOW + SWP_NOSIZE)
            oFrm.Show vbModeless
            Set oCGroup = New CGroup
            If oGroupsCollection Is Nothing Then
            Set oGroupsCollection = New Collection
            End If
            oCGroup.Z_DO_NOT_USE_THIS_METHOD_HOOK_FORM oFrm
            oGroupsCollection.Add oCGroup
            Set oCGroup = Nothing
            oFirstGroupInstance.Z_DO_NOT_USE_THIS_METHOD_ADD_TO_FORMS_COLLECTION oFrm
        End If
    Next oFrm
    
    Call Application.OnTime(Now, "ActivateFirstForm")
    Call SetTimer(Application.hwnd, 0, 0, AddressOf MonitorUserForms)

End Sub

Public Sub MoveProc()
    Const WM_NCLBUTTONDOWN = &HA1
    Const HTCAPTION = 2
    
    Call ReleaseCapture
    Call PostMessage(hContainer, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End Sub

Public Function GetTheActiveForm() As Object

    Dim oFormDisp As Object
    
    If hLastActiveForm Then
        Set oFormDisp = GetFormDisp(hLastActiveForm)
        If Not oFormDisp Is Nothing Then
            If TypeOf oFormDisp Is MSForms.Control Then
                Set GetTheActiveForm = GetActualActiveForm(oFormDisp)
            Else
                Set GetTheActiveForm = oFormDisp
            End If
        End If
    End If

End Function

Public Function GetFormsCount() As Long
    GetFormsCount = GetChildCount(hContainer)
End Function


'__________________________________PRIVATE ROUTINES______________________________________________

Private Sub BuildFormConaitner()
    
    FrmContainer.StartUpPosition = 0
    FrmContainer.BackColor = 3342489
    Call IUnknown_GetWindow(FrmContainer, VarPtr(hContainer))
    Call ChangeContainerStyles(hContainer)
    Call HideFromTaksbar
    Call Application.OnTime(Now, "DisplayContainer")
End Sub

Private Sub DisplayContainer()

    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    Const SWP_NOACTIVATE = &H10
    Const SWP_SHOWWINDOW = &H40
    Const SM_CYCAPTION = 4

    Call SetWindowPos(hContainer, 0, (GetSystemMetrics(SM_CXSCREEN) - PTtoPX(W, False)) / 2, _
        (GetSystemMetrics(SM_CYSCREEN) - PTtoPX(H, True)) / 2, PTtoPX(W, False), _
        PTtoPX(H, True) + 2 * GetSystemMetrics(SM_CYCAPTION), SWP_SHOWWINDOW + SWP_NOACTIVATE)

End Sub

Private Sub MonitorUserForms()

    Dim bSuccess As Boolean
    Dim tCurPos As POINTAPI
    Dim lChildCount As Long
    Dim lNewLeftPos As Long
    
    If bExecuting = False Then
        Call CleanUp
        Debug.Print "Unexpected error... Timer safely released."
    End If
    
    lChildCount = GetChildCount(hContainer)
    
    If lChildCount = 0 Then
        Debug.Print "Groups and all userforms closed successfully."
        Call CleanUp
        Exit Sub
    End If
    
    If bFormClosed Then
        bFormClosed = False
        If IsAnyFormOffScreen(lNewLeftPos) Then
            Debug.Print "Forms off-screen. Bring them back to view."
            Call BringBackOffScreenFormsToView(lNewLeftPos)
        End If
    End If
    
    Call GetCursorPos(tCurPos)

    #If Win64 Then
        Dim Ptr As LongLong, hWinFromPt As LongLong
        Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
        hWinFromPt = WindowFromPoint(Ptr)
    #Else
        Dim hWinFromPt As Long
        hWinFromPt = WindowFromPoint(tCurPos.X, tCurPos.y)
    #End If
        
    If hWinFromPt Then
        If IsWindowUserForm(hWinFromPt) Then
            bSuccess = True
            hLastActiveForm = hWinFromPt
        End If
        
        If bSuccess = False Then
            If IsWindowUserForm(GetParent(hWinFromPt)) Then
                bSuccess = True
                hLastActiveForm = GetParent(hWinFromPt)
            End If
        End If
        
        If bSuccess Then
            If IsWindowEnabled(hContainer) Then
                Call SetActiveWindow(hLastActiveForm)
            End If
        End If
    End If

End Sub

Private Sub CleanUp()

    Dim i As Long
    
    Call KillTimer(Application.hwnd, 0)
    bExecuting = False
    bFormClosed = False
    W = 0: H = 0
    hContainer = 0
    hLastActiveForm = 0
    
    If Not oGroupsCollection Is Nothing Then
        For i = 1 To oGroupsCollection.Count
            oGroupsCollection.Remove 1
        Next i
    End If
    
    Set oFirstGroupInstance = Nothing
    Set oGroupsCollection = Nothing
    Unload FrmContainer

End Sub

Private Sub ActivateFirstForm()
    Call IUnknown_GetWindow(oFirstGroupInstance.FormsCollection(1), VarPtr(hLastActiveForm))
    Call SetActiveWindow(hLastActiveForm)
End Sub

#If Win64 Then
    Private Function GetChildCount(ByVal hwnd As LongLong) As Long
#Else
    Private Function GetChildCount(ByVal hwnd As Long) As Long
#End If

    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_CLIENT = &HFFFFFFFC
    Const S_OK = &H0

    Dim tGUID(0 To 3) As Long
    Dim oIAc As IAccessible
    
    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
        If AccessibleObjectFromWindow(hwnd, OBJID_CLIENT, VarPtr(tGUID(0)), oIAc) = S_OK Then
            GetChildCount = oIAc.accChildCount - 1
            If lPrevChildCount > oIAc.accChildCount - 1 Then
                Call RebuildFormsCollection
                bFormClosed = True
            End If
        End If
    End If
    lPrevChildCount = oIAc.accChildCount - 1

End Function

Private Sub RebuildFormsCollection()

    Dim i As Long
    
    With oFirstGroupInstance
        If Not oFirstGroupInstance Is Nothing Then
            For i = 1 To .FormsCollection.Count
                .FormsCollection.Remove 1
            Next i
            For i = 0 To VBA.UserForms.Count - 1
                If Left(UserForms(i).Tag, 3) = "frm" Then
                    .Z_DO_NOT_USE_THIS_METHOD_ADD_TO_FORMS_COLLECTION UserForms(i)
                End If
            Next i
        End If
    End With

End Sub

Private Function IsAnyFormOffScreen(ByRef lNewLeftPos As Long) As Boolean

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If
    
    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    Dim tScreenRect As RECT, tFormRect As RECT, tDestRect As RECT
    Dim i As Long
    
    Call SetRect(tScreenRect, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
    For i = 0 To VBA.UserForms.Count - 1
        If Left(UserForms(i).Tag, 3) = "frm" Then
            Call IUnknown_GetWindow(UserForms(i), VarPtr(hwnd))
            Call GetWindowRect(hwnd, tFormRect)
            If IntersectRect(tDestRect, tScreenRect, tFormRect) = 0 Then
                If tFormRect.Left <= 0 Then
                    lNewLeftPos = -tFormRect.Left
                ElseIf tFormRect.Left >= GetSystemMetrics(SM_CXSCREEN) Then
                    lNewLeftPos = GetSystemMetrics(SM_CXSCREEN) - tFormRect.Right
                End If
                IsAnyFormOffScreen = True
                Exit For
            End If
        End If
    Next i

End Function

Private Sub BringBackOffScreenFormsToView(ByRef lNewLeftPos As Long)
      
    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOSIZE = &H1
    Dim tContainerRect As RECT
    
    GetWindowRect hContainer, tContainerRect
    Call SetWindowPos(hContainer, 0, tContainerRect.Left + lNewLeftPos, tContainerRect.Top, _
        0, 0, SWP_SHOWWINDOW + SWP_NOSIZE)
    Call SetActiveWindow(GetNextWindow(hContainer, 5))
    hLastActiveForm = GetNextWindow(hContainer, 5)

End Sub


#If Win64 Then
    Private Sub ChangeContainerStyles(ByVal hwnd As LongLong)
        Dim lStyle As LongLong, lExStyle As LongLong
#Else
    Private Sub ChangeContainerStyles(ByVal hwnd As Long)
        Dim lStyle As Long, lExStyle As Long
#End If

    Const GWL_EXSTYLE = (-20)
    Const GWL_STYLE = -16
    Const WS_CAPTION = &HC00000
    Const WS_EX_LAYERED = &H80000
    Const LWA_COLORKEY = &H1
    Const WS_EX_DLGMODALFRAME = &H1

    lExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
    lExStyle = (lExStyle Or WS_EX_LAYERED) And Not WS_EX_DLGMODALFRAME
    Call SetWindowLong(hwnd, GWL_EXSTYLE, lExStyle)
    Call SetLayeredWindowAttributes(hwnd, FrmContainer.BackColor, 0, LWA_COLORKEY)
    
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
    lStyle = lStyle And Not WS_CAPTION
    Call SetWindowLong(hwnd, GWL_STYLE, lStyle)
    Call DrawMenuBar(hwnd)

End Sub

Private Function GetActualActiveForm(ByVal Ctrl As Object) As Object
    Set GetActualActiveForm = Ctrl.Parent
    Do While TypeOf GetActualActiveForm Is MSForms.Control
        Set GetActualActiveForm = GetActualActiveForm.Parent
    Loop
End Function

#If Win64 Then
    Private Function IsWindowUserForm(ByVal hwnd As LongLong) As Boolean
#Else
    Private Function IsWindowUserForm(ByVal hwnd As Long) As Boolean
#End If

    Dim sBuffer  As String * 256, lRet As Long
    
    lRet = GetClassName(hwnd, sBuffer, 256)
    If Left(sBuffer, lRet) = "ThunderDFrame" Or Left(sBuffer, lRet) = "ThunderXFrame" Then
        IsWindowUserForm = True
    End If

End Function

Private Sub HideFromTaksbar()
    Const GWL_EXSTYLE = (-20)
    Const WS_EX_APPWINDOW = &H40000
    
    Call SetWindowLong(hContainer, GWL_EXSTYLE, _
        GetWindowLong(hContainer, GWL_EXSTYLE) And Not WS_EX_APPWINDOW)
End Sub

#If Win64 Then
    Private Function GetFormDisp(ByVal hwnd As LongLong) As Object
        Dim hClient As LongLong, lResult As LongLong
#Else
    Private Function GetFormDisp(ByVal hwnd As Long) As Object
        Dim hClient As Long, lResult As Long
#End If

    Const WM_GETOBJECT = &H3D&
    Const OBJID_CLIENT = &HFFFFFFFC
    Const GW_CHILD = 5
    Const S_OK = 0&
    Const IID_IDISPATCH = "{00020400-0000-0000-C000-000000000046}"
    
    Dim uGUID As GUID
    Dim oForm As Object
    
    hClient = GetNextWindow(hwnd, GW_CHILD)
    lResult = SendMessage(hClient, WM_GETOBJECT, 0, ByVal OBJID_CLIENT)
    If lResult Then
        If IIDFromString2(StrPtr(IID_IDISPATCH), uGUID) = S_OK Then
            If ObjectFromLresult(lResult, uGUID, 0, oForm) = S_OK Then
                If Not oForm Is Nothing Then
                    Set GetFormDisp = oForm
                End If
            End If
        End If
    End If

End Function

Private Function ScreenDPI(bVert As Boolean) As Long

    Const LOGPIXELSX = 88
    Const LOGPIXELSY = 90

    Static lDPI(1), lDC

    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
  
End Function
 
Private Function PTtoPX(Points As Double, bVert As Boolean) As Long
    Const POINTS_PER_INCH = 72
    PTtoPX = Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function

3- Usage Example code:

Option Explicit

Dim oGroup As CGroup

Sub Test()

    Set oGroup = New CGroup
    With oGroup
        .AddForm Frm:=UserForm1, Gap:=20
        .AddForm Frm:=UserForm2, Gap:=20
        .AddForm Frm:=UserForm3
        .Execute
    End With

End Sub

Sub Info_Button_Click(Optional ByVal Dummy As Boolean)

    Dim oActiveForm As Object
    
    Set oActiveForm = oGroup.Z_DO_NOT_USE_THIS_METHOD_ACTIVE_FORM
    If Not oActiveForm Is Nothing Then
        MsgBox "* Active UserForm:   [" & oGroup.Z_DO_NOT_USE_THIS_METHOD_ACTIVE_FORM.Name & "]" & _
                vbNewLine & vbNewLine & "* Total UserForms Count In Group:   [" & oGroup.FormsCount & "]"
    End If

End Sub

 

[Tom.Jones]

@JAAFAR.

Amazing. As always. Thank you.

 

[Peter_SSs]

@Tom.Jones
Are you aware that you have tagged a member who has not been on the forum for 20 years! and never posted anything - not the person who has done all the hard work in this thread? ?

 

[Jaafar Tribak]

View attachment 59412

@Tom.Jones
Are you aware that you have tagged a member who has not been on the forum for 20 years! and never posted anything - not the person who has done all the hard work in this thread? ?

That account is probably mine as well (was opened the same year and the same day as my current account). Maybe I forgot the password already and decided to open a new account

Wow, 20 years have already passed. Gosh!!

 

[Jaafar Tribak]

Correction of a small mistake:

The following Class Method is supposed to be seen and used by client code

Public Function Z_DO_NOT_USE_THIS_METHOD_ACTIVE_FORM() As Object
    Set Z_DO_NOT_USE_THIS_METHOD_ACTIVE_FORM = GetTheActiveForm
End Function

So I have now changed its name to:

Public Function GetActiveForm() As Object
    Set GetActiveForm = GetTheActiveForm
End Function

Resulting Client code becomes :

Option Explicit

Dim oGroup As CGroup

Sub Test()

    Set oGroup = New CGroup
    With oGroup
        .AddForm Frm:=UserForm1, Gap:=20
        .AddForm Frm:=UserForm2, Gap:=20
        .AddForm Frm:=UserForm3
        .Execute
    End With

End Sub

Sub Info_Button_Click(Optional ByVal Dummy As Boolean)

    Dim oActiveForm As Object
    
    Set oActiveForm = oGroup.GetActiveForm
    
    If Not oActiveForm Is Nothing Then
        MsgBox "* Active UserForm:   [" & oActiveForm.Name & "]" & _
                vbNewLine & vbNewLine & "* Total UserForms Count In Group:   [" & oGroup.FormsCount & "]"
    End If

End Sub

 

[Tom.Jones]

@Tom.Jones
Are you aware that you have tagged a member who has not been on the forum for 20 years! and never posted anything - not the person who has done all the hard work in this thread? ?

That account is probably mine as well (was opened the same year and the same day as my current account). Maybe I forgot the password already and decided to open a new account

Wow, what a terrible mistake I made ..... Obviously I didn't know of another Jaafar
I propose the maximum penalty ....

Tom

 

[Peter_SSs]

That account is probably mine as well

If it was yours, do you think that other account could that have had an email address with a UK domain?