Grouping UserForms [Having userforms follow each other when moved around the screen]

Jaafar Tribak · Sep 25, 2022

Hi,

This is a vba code that hopefully accomplishes what the title of the thread says. Obviously, the forms must be modeless so that the user can freely move from one form to aanother. Problem is, using modeless forms makes this task difficult as we cannot subclass modeless forms to properly intercept and handle the mouse_move messages. Only modal forms can be subclassed. Same problem with mouse Window hooks.

So I decided to experiment with a windows timer to monitor the moving of the userforms and this is what I have come to.

Basically, each form is programmatically assigned a checkbox button on the titlebar next to the form's close X button (see preview). This button will take charge of toggling the Grouping state of the form.

I wrote some code some time ago for grouping forms but it was very limited compared to this one.

UserFormsGrouping.xlsm

The sluggish movement that appears in the following preview is due to the screen recording software. The actual project is much smoother.

1- API code in a Standard Module:

VBA Code:

Option Explicit

Private Type POINTAPI
    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 Type MSG
    #If Win64 Then
        hWnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
    #Else
        hWnd As Long
        message As Long
        wParam As Long
        lParam As Long
    #End If
    time As Long
    pt As POINTAPI
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongLong)
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongLong
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long) As LongLong
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function EnableWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal fEnable As Long) As Long
    Private Declare PtrSafe Function GetFocus Lib "user32" () 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 GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SetActiveWindow Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    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 IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPtr
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hWnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat 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 IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid 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 AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare PtrSafe Function DwmIsCompositionEnabled Lib "dwmapi" (ByRef pfEnabled As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
#Else
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
    Private Declare Function GetFocus Lib "user32" () As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat 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 IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid 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 AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare Function DwmIsCompositionEnabled Lib "dwmapi" (ByRef pfEnabled As Long) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
#End If

Private oColl As Collection



Public Sub AddFormToGroup(ByVal UF As UserForm)

    Const GWL_HWNDPARENT = (-8)
    Const GWL_USERDATA = (-21)
    Const WS_EX_LAYERED = &H80000
    Const WS_EX_NOACTIVATE = &H8000000
    Const LWA_COLORKEY = &H1
    Const COLOR_WINDOW = 5
    Const COLOR_BTNFACE = 15
    Const WS_VISIBLE = &H10000000
    Const WS_POPUP = &H80000000
    Const WS_BORDER = &H800000
    Const BS_AUTOCHECKBOX = &H3&
    Const BS_RIGHTBUTTON = &H20
    Const BS_VCENTER As Long = &HC00

    #If Win64 Then
        Dim hWnd As LongLong, hButton As LongLong
    #Else
        Dim hWnd As Long, hButton As Long
    #End If
    Dim tFormRect As RECT
    Dim lWinStyle As Long, lWinExStyle As Long, lNewColor As Long
 
    Call IUnknown_GetWindow(UF, VarPtr(hWnd))
    lWinStyle = WS_POPUP + WS_VISIBLE + BS_RIGHTBUTTON + BS_VCENTER + BS_AUTOCHECKBOX + WS_BORDER
    lWinExStyle = WS_EX_NOACTIVATE + IIf(IsAeroEnabled, WS_EX_LAYERED, 0)

    hButton = CreateWindowEx(lWinExStyle, StrPtr("BUTTON"), StrPtr(ChrW(9724) & "GRP"), _
                lWinStyle, 0&, 0&, 0&, 0&, 0&, 0&, GetModuleHandle(vbNullString), ByVal 0&)
    Call TranslateColor(GetSysColor(COLOR_BTNFACE), 0, lNewColor)
    Call SetLayeredWindowAttributes(hButton, lNewColor, 0, LWA_COLORKEY)
  
    Call SetWindowLong(hButton, GWL_HWNDPARENT, hWnd)
    Call SetWindowLong(hWnd, GWL_USERDATA, hButton)
    Call SetWindowLong(hButton, GWL_USERDATA, hWnd)
  
    Call GetWindowRect(hWnd, tFormRect)
    Call SetProp(hWnd, "LEFT", tFormRect.Left)
    Call SetProp(hWnd, "TOP", tFormRect.Top)
  
    If oColl Is Nothing Then
        Set oColl = New Collection
    End If
    oColl.Add hButton
    Call ShowCheckButton(UF)
  
End Sub



'____________________________________________ Private Routines ___________________________________________

Private Sub ShowCheckButton(ByVal UF As UserForm)
    Call SetCheckButtonsPos(UF)
    MonitoringMovingOfUserForms = True
End Sub

Private Sub SetFormsPos()

    Const BM_GETCHECK = &HF0
    Const BST_CHECKED = &H1
    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const SWP_NOSIZE = &H1
    Const SWP_NOZORDER = &H4
    Const GWL_USERDATA = (-21)

    #If Win64 Then
        Dim hForm As LongLong
        Dim lCheckBoxState1 As LongLong, lCheckBoxState2 As LongLong
    #Else
        Dim hForm As Long
        Dim lCheckBoxState1 As Long, lCheckBoxState2 As Long
    #End If
  
    Static tPrevCurPos As POINTAPI
 
    Dim oForm As UserForm
    Dim lMouseOffsetX As Long
    Dim lMouseOffsetY As Long
    Dim sBuff As String * 256, lRet As Long
    Dim tRect As RECT, tCurPos As POINTAPI

    MonitoringMovingOfUserForms = False

    If IsCaptionClick Then
        Call SaveInitPos
    End If
  
    If FormsOffScreen Then
        Call RestoreInitPos
    End If
  
    If Not IsMouseOverTitleBar(GetActiveWindow) Then
        If GetAsyncKeyState(VBA.vbKeyLButton) Then
            GoTo NextTimerCycle
        End If
    End If
  
    If IsAltPlusF4 Then
      Call SetActiveWindow(GetWindowLong(GetFocus, GWL_USERDATA))
    End If
  
    If VBA.UserForms.Count = 0 Then
        Call Cleanup(tPrevCurPos)
        Exit Sub
    End If

    Call GetCursorPos(tCurPos)
    With tPrevCurPos
        lMouseOffsetX = tCurPos.x - .x
        lMouseOffsetY = tCurPos.y - .y
    End With

    For Each oForm In VBA.UserForms
  
        Call IUnknown_GetWindow(oForm, VarPtr(hForm))
      
        If IsWindowEnabled(Application.hWnd) = 0 Then
            Call EnableWindow(GetWindowLong(hForm, GWL_USERDATA), 0)
        Else
            Call EnableWindow(GetWindowLong(hForm, GWL_USERDATA), 1)
        End If
      
        Call SetCheckButtonsPos(oForm)

        If GetAsyncKeyState(VBA.vbKeyLButton) Then
            If GetActiveWindow <> hForm Then
                lRet = GetClassName(hForm, sBuff, 256)
                If Left(sBuff, lRet) Like "Thunder?Frame" Then
                    If IsWindowEnabled(Application.hWnd) Then
                        lCheckBoxState1 = SendMessage(GetWindowLong(hForm, GWL_USERDATA), BM_GETCHECK, 0, 0)
                        lCheckBoxState2 = SendMessage(GetWindowLong(GetActiveWindow, GWL_USERDATA), BM_GETCHECK, 0, 0)
                        If lCheckBoxState1 = BST_CHECKED And lCheckBoxState2 = BST_CHECKED Then
                            If GetWindowLong(hForm, GWL_USERDATA) Then
                                Call GetWindowRect(hForm, tRect)
                                With tRect
                                    Call SetWindowPos(hForm, 0&, .Left + lMouseOffsetX, .Top + lMouseOffsetY, _
                                          0&, 0&, SWP_NOACTIVATE + SWP_SHOWWINDOW + SWP_NOZORDER + SWP_NOSIZE)
                                End With
                            End If
                        End If
                    End If
                End If
            End If
        End If
  
    Next oForm

    tPrevCurPos = tCurPos

NextTimerCycle:
 
    MonitoringMovingOfUserForms = True

End Sub

Private Sub SetCheckButtonsPos(ByVal ParentUserForm As UserForm)
    Const GWL_USERDATA = (-21)
    Const WM_NCACTIVATE = &H86
    Const HWND_NOTOPMOST = -2
    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const DT_CALCRECT = &H400

    #If Win64 Then
        Dim hWnd As LongLong, hDC As LongLong
    #Else
        Dim hWnd As Long, hDC As Long
    #End If
    Dim tCloseButtonRect As RECT, tTextRect As RECT
 
    Call IUnknown_GetWindow(ParentUserForm, VarPtr(hWnd))
    Call KillTimer(GetWindowLong(hWnd, GWL_USERDATA), 0)
    If IsWindowVisible(hWnd) Then
        tCloseButtonRect = GetCloseButtonRect(ParentUserForm)
        hDC = GetDC(GetWindowLong(hWnd, GWL_USERDATA))
        Call DrawText(hDC, StrPtr(ChrW(9724) & "GRP"), Len(ChrW(9724) & "GRP"), tTextRect, DT_CALCRECT)
        Call ReleaseDC(GetWindowLong(hWnd, GWL_USERDATA), hDC)
        With tTextRect
            Call SetWindowPos(GetWindowLong(hWnd, GWL_USERDATA), HWND_NOTOPMOST, _
                tCloseButtonRect.Left - 1.6 * (.Right - .Left), tCloseButtonRect.Top + 2, _
                1.6 * (.Right - .Left), tCloseButtonRect.Bottom - tCloseButtonRect.Top - 4, _
                SWP_NOACTIVATE + SWP_SHOWWINDOW)
        End With
    End If
      
    If GetFocus = GetWindowLong(hWnd, GWL_USERDATA) Then
        Call SendMessage(hWnd, WM_NCACTIVATE, True, 0)
    End If
End Sub

Private Property Let MonitoringMovingOfUserForms(ByVal bMonitor As Boolean)
    If bMonitor Then
        Call KillTimer(Application.hWnd, 0)
        Call SetTimer(Application.hWnd, 0, 0, AddressOf SetFormsPos)
    Else
        Call KillTimer(Application.hWnd, 0)
    End If
End Property
 
#If Win64 Then
    Private Function IsMouseOverTitleBar(ByVal hWnd As LongLong) As Boolean
#Else
    Private Function IsMouseOverTitleBar(ByVal hWnd As Long) As Boolean
#End If
  
    Const SM_CYCAPTION = 4
    Const SM_CYBORDER = 6
    Const SM_CYDLGFRAME = 8
    Const SM_CYEDGE = 46
    Const SM_CYFIXEDFRAME = 8
    Dim tCaptionRect As RECT, tCurPos As POINTAPI, lRet As Long
  
    Call GetWindowRect(hWnd, tCaptionRect)
    With tCaptionRect
        .Bottom = .Top + GetSystemMetrics(SM_CYCAPTION) + _
                GetSystemMetrics(SM_CYEDGE) + _
                GetSystemMetrics(SM_CYFIXEDFRAME) + _
                GetSystemMetrics(SM_CYBORDER) + _
                GetSystemMetrics(SM_CYDLGFRAME)
    End With
 
    Call GetCursorPos(tCurPos)
 
    #If Win64 Then
        Dim lPtr As LongLong
        Call CopyMemory(lPtr, tCurPos, LenB(tCurPos))
        lRet = PtInRect(tCaptionRect, lPtr)
    #Else
        lRet = PtInRect(tCaptionRect, tCurPos.x, tCurPos.y)
    #End If
 
    If lRet Then
        IsMouseOverTitleBar = True
    End If

End Function

Private Sub SaveInitPos()
    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
    Dim oForm As UserForm, tFormRect As RECT

    For Each oForm In VBA.UserForms
        Call IUnknown_GetWindow(oForm, VarPtr(hForm))
        If Not IsFormOffScreen(hForm) Then
            Call GetWindowRect(hForm, tFormRect)
            Call SetProp(hForm, "LEFT", tFormRect.Left)
            Call SetProp(hForm, "TOP", tFormRect.Top)
        End If
    Next oForm
End Sub


#If Win64 Then
    Private Function IsFormOffScreen(ByVal hForm As LongLong) As Boolean
#Else
    Private Function IsFormOffScreen(ByVal hForm As Long) As Boolean
#End If
    Const SPI_GETWORKAREA = 48
    Dim tFormRect As RECT, tScreenRect As RECT, tIntersectRect As RECT

    Call SystemParametersInfo(SPI_GETWORKAREA, 0&, tScreenRect, 0&)
    Call GetWindowRect(hForm, tFormRect)
    If IntersectRect(tIntersectRect, tFormRect, tScreenRect) = 0 Then
        IsFormOffScreen = True
    End If
End Function


Private Sub RestoreInitPos()
    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const SWP_NOSIZE = &H1
    Const SWP_NOZORDER = &H4
    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
    Static FormsCount As Long
    Dim oForm As UserForm
  
    If FormsCount > VBA.UserForms.Count Then
        For Each oForm In VBA.UserForms
            Call IUnknown_GetWindow(oForm, VarPtr(hForm))
            Call SetWindowPos(hForm, 0&, CLng(GetProp(hForm, "LEFT")), CLng(GetProp(hForm, "TOP")), _
                    0&, 0&, SWP_NOACTIVATE + SWP_SHOWWINDOW + SWP_NOZORDER + SWP_NOSIZE)
        Next oForm
    End If
    FormsCount = VBA.UserForms.Count
End Sub

Private Function FormsOffScreen() As Boolean
  
    Const SM_CYCAPTION = 4
    Const SM_CYBORDER = 6
    Const SM_CYDLGFRAME = 8
    Const SM_CYEDGE = 46
    Const SM_CYFIXEDFRAME = 8
    Const SPI_GETWORKAREA = 48

    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
    Dim tFormRect As RECT, tScreenRect As RECT, tIntersectRect As RECT
    Dim oForm As UserForm
  
    If GetAsyncKeyState(VBA.vbKeyLButton) = 0 Then
        Call SystemParametersInfo(SPI_GETWORKAREA, 0&, tScreenRect, 0&)
        With tScreenRect
            .Left = .Left + GetSystemMetrics(SM_CYCAPTION)
            .Bottom = .Bottom - GetSystemMetrics(SM_CYCAPTION)
            .Right = .Right - GetSystemMetrics(SM_CYCAPTION)
        End With
        For Each oForm In VBA.UserForms
            Call IUnknown_GetWindow(oForm, VarPtr(hForm))
            Call GetWindowRect(hForm, tFormRect)
            tFormRect.Bottom = tFormRect.Top + GetSystemMetrics(SM_CYCAPTION) / 2
            If IntersectRect(tIntersectRect, tFormRect, tScreenRect) = 0 Then
                FormsOffScreen = True: Exit For
            End If
        Next oForm
    End If
End Function

Private Function IsAltPlusF4() As Boolean
    Dim sBuff As String * 256, lRet As Long
    If GetKeyState(vbKeyMenu) And &H8000 Then
        lRet = GetClassName(GetFocus, sBuff, 256)
        If UCase(Left(sBuff, lRet)) = "BUTTON" Then
            IsAltPlusF4 = True
        End If
    End If
End Function

Private Function IsCaptionClick() As Boolean
    Const PM_NOREMOVE = &H0
    Const WM_NCLBUTTONDOWN = &HA1
    Const HTCLOSE = 20
    Dim tMsg As MSG
  
    Call WaitMessage
    If PeekMessage(tMsg, 0&, 0&, 0&, PM_NOREMOVE) Then
        If tMsg.message = WM_NCLBUTTONDOWN And tMsg.wParam <> HTCLOSE Then
            IsCaptionClick = True
        End If
    End If
End Function

Private Function GetCloseButtonRect(ByVal UF As UserForm) As RECT
    Const STATE_SYSTEM_INVISIBLE = &H8000&
    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
    Dim oAcc As IAccessible, vAccChildren As Variant
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim i As Long

    Call IUnknown_GetWindow(UF, VarPtr(hForm))
    Set oAcc = GetBrowserAccName(hForm)
    Do
        i = i + 1
        Call AccessibleChildren(oAcc, 0&, 1&, vAccChildren, 0&)
        If oAcc.accState(i) <> STATE_SYSTEM_INVISIBLE Then
            oAcc.accLocation lLeft, lTop, lWidth, lHeight, 5&
            Call SetRect(GetCloseButtonRect, lLeft, lTop, lWidth + lLeft, lHeight + lTop)
            Exit Do
        End If
    Loop Until i > oAcc.accChildCount
End Function

#If Win64 Then
    Private Function GetBrowserAccName(ByVal hWnd As LongLong) As IAccessible
#Else
    Private Function GetBrowserAccName(ByVal hWnd As Long) As IAccessible
#End If

    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_TITLEBAR = -2
    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_TITLEBAR, VarPtr(tGUID(0)), oIAc) = S_OK Then
           Set GetBrowserAccName = oIAc
        End If
    End If

End Function

Private Function IsAeroEnabled() As Boolean
    Dim bEnabled As Long
    Call DwmIsCompositionEnabled(bEnabled)
    IsAeroEnabled = CBool(bEnabled)
End Function

Private Sub Cleanup(ByRef CurPos As POINTAPI)
    Dim lTimerRet As Long, i As Long
    'Debug.Print "Timer ret: ", lTimerRet
    'if lTimerRet is non zero,it means the timer was safely released.
    'All checkbox buttons should be automatically destroyed
    'along with their respective userform owner windows.
    'Nevertheless, do explicitly destroy them just in case.
        lTimerRet = KillTimer(Application.hWnd, 0)
        If Not oColl Is Nothing Then
            For i = 1 To oColl.Count
                Call DestroyWindow(oColl(i))
            Next
            Set oColl = Nothing
        End If
        CurPos.x = 0: CurPos.y = 0
        'Debug.Print "checkbuttons destroyed... - done."
End Sub

Private Sub Auto_Close()
    Dim oForm As UserForm
    Call KillTimer(Application.hWnd, 0)
    For Each oForm In VBA.UserForms
        Unload oForm
    Next
End Sub

2- Code Usage in the UserForm module:

VBA Code:

Option Explicit

Private Sub UserForm_Initialize()
    Call AddFormToGroup(Me)
End Sub

Tested on (Win7 Pro x32bit Excel 2007) and on (Win10 x64bit Excel 2016 x64bit)

Regards.

Dan_W · Sep 26, 2022

... but ... but... I really like the previous version... That said, I'm (curious and am) looking forward to trying this one out later.

And as usual, you've somehow managed to magically answer in your posted code a couple of questions I've been pondering for a while, or on points I'm about to research. For example
(1) Case in point: there was this query yesterday about system-wide mouse movement detection: link. I was looking at a mouse hook solution, but I was chatting with @Gokhan Aycan and he very helpfully pointed out that others have had issues problems with it, and you had warned about it too.
(2) There are some new (well.. new to me, at least) functions above that will be very useful in my projects - the one that jumped out at me was IsAeroEnabled. I have been thinking about implementing the GDI+ blur routine you posted a while back and applying that to a screencapture of the rect behind the userform's location so as to mimic a kind of glass effect... I have no idea yet as to it's viability (my sense is that it's maybe a bit slow to update if the Userform is moved and needs to update it) but then I stumbled across DwmEnableBlurBehindWindow - but wasn't sure if the dwmapi library, and its array of functions, were deprecated or available in VBA, and now you posted this! Looking forward to exploring it some more.

As ever, thank you very much.

Tom.Jones · Sep 26, 2022

JAAFAR,

Excellent !!!!

Win64, Excel32-64

Jaafar Tribak · Sep 26, 2022

... but ... but... I really like the previous version...

Although the previous version was less CPU hungry, it was less user\coder friendly and was less flexible.

The previous version would only allow for forms to be displayed horizontally. Also, once the group of forms would get displayed, there was no way afterwards for the user to add new forms to the group or to ungroup individual forms.

... about system-wide mouse movement detection: link. I was looking at a mouse hook solution, but I was chatting with @Gokhan Aycan and he very helpfully pointed out that others have had issues problems with it

As I mentioned in my first post, I believe, subclassing or installing a windows mouse hook would be ideal for accomplishing this userform-grouping functionality [Would result in a much smoother/Less Sluggish Movement] but, unfortunately, modeless forms would immediately crash.

Just for curiosity's sake, If I find the time, I will go ahead and try installing a low level mouse hook in a seperate hidden excel instance created on the fly. Since the mouse hook callback will now be executing behind the scenes in a separate excel process, there will be no risk of crashing excel, not even if unhandled errors occur or if the IDE is stopped while the hook is still in place. This should also make the dragging\moving of the forms (and the toggle checkbox in the forms titlebar) much smoother than when using a windows timer.

I stumbled across DwmEnableBlurBehindWindow - but wasn't sure if the dwmapi library, and its array of functions, were deprecated or available in VBA

I am not entirely sure but, I think in Win10, you will need to use SetWindowCompositionAttribute

Dan_W · Sep 26, 2022

Jaafar Tribak said:
The previous version would only allow for forms to be displayed horizontally. Also, once the group of forms would get displayed, there was no way afterwards for the user to add new forms to the group or to ungroup individual forms.

Ahh yes, now that you mention it, that's true - I hadn't noticed that. I think that's because how it works 'straight out of the box' is probably how I would want to use it.

Jaafar Tribak said:
a seperate hidden excel instance created on the fly

I've actually been thinking about the benefits of this approach more and more recently, and again when I was going over the code for your Clipboard workbook that you posted the other day - I was gleefully pressing the stop button over and over again only see it (a) didn't crash, and (b) kept updating the workbook with the clipboard contents. Obviously, I was able to make it crash by putting the IDE into break mode... at which point I wondered whether THAT clipboard routine would also make a good candidate for the super secret hidden excel instance method - maybe call it the xlAppVeryHidden method?

Jaafar Tribak said:
I am not entirely sure but, I think in Win10, you will need to use SetWindowCompositionAttribute

Thank you! This would never have occurred to me. I will look into that.

Jaafar Tribak · Sep 29, 2022

Update.

In the last 2 days, I have been testing a system wide windows mouse hook executed from a second instance of excel but for some very weird reason, the WM_NCMOUSEMOVE and WM_NCLBUTTONDOWN messages are not intercepted. Only Client messages could be trapped. So, in the end, I decided to leave the windows hook approach and try something else.

I gave the commandbars OnUpdate event a shot and to my surprise, it worked extremly well !

So, here is the final code that I have ended up with. The result is surprisingly smooth. Furthermore, the code is extremly esay to use and more importantly, it is now very safe and stable as it doesn't use a windows timer or a mouse hook.

UserFormsGrouping_V2_WithoutTimer.xlsm

Here is the entire api code:

1- In a Class Module CGroup

VBA Code:

Option Explicit

Private WithEvents UFEvents As msforms.UserForm
Private WithEvents CmbrsEvents As CommandBars

Private Enum QUADRANT
    °LEFT
    °RIGHT
    °TOP
    °BOTTOM
End Enum

Private Type POINTAPI
    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 Type PIVOT_FORM
    #If Win64 Then
        hWnd As LongLong
    #Else
        hWnd As Long
    #End If
    RC As RECT
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongLong, ByVal nIndex As Long) As LongLong
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    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 UnionRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare PtrSafe Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) 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 GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As LongPtr, ByVal lpStr As LongPtr, ByVal nCount As Long, lpRect As RECT, ByVal wFormat 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 IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid 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 AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare PtrSafe Function DwmIsCompositionEnabled Lib "dwmapi" (ByRef pfEnabled As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
    Private Declare PtrSafe Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
 
    Private hThisForm As LongPtr
#Else
    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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As Long) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetFocus Lib "user32" () As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 UnionRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) 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 GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat 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 IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid 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 AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare Function DwmIsCompositionEnabled Lib "dwmapi" (ByRef pfEnabled As Long) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
    Private Declare Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
 
    Private hThisForm As Long
#End If


Private bFisrtLayoutEventRun As Boolean


'___________________________________________ CLASS INIT\TERM ________________________________________________

Private Sub Class_Initialize()
    bFisrtLayoutEventRun = True
End Sub

Private Sub Class_Terminate()
    Const GWL_USERDATA = (-21)
    If IsWindow(GetWindowLong(hThisForm, GWL_USERDATA)) Then
        Call DestroyWindow(GetWindowLong(hThisForm, GWL_USERDATA))
    End If
    If UserForms.Count = 0 Then
        Call RemoveProp(Application.hWnd, "hActiveForm")
        Call RemoveProp(Application.hWnd, "ActiveFormLeft")
        Call RemoveProp(Application.hWnd, "ActiveFormTop")
        PreventSleepMode = False
    End If
End Sub


'___________________________________________ PUBLIC CLASS METHOD ______________________________________________

Public Sub AttachForm(ByVal UForm As UserForm)
    Set UFEvents = UForm
End Sub




'___________________________________________ PRIVATE ROUTINES ______________________________________________

Private Sub CmbrsEvents_OnUpdate()
    Const WM_NCACTIVATE = &H86
    Const GWL_USERDATA = (-21)
    Dim tFormRect As RECT, tUnionRect As RECT
 
    If GetProp(Application.hWnd, "hActiveForm") <> GetActiveWindow Then
        If GetAsyncKeyState(VBA.vbKeyLButton) Then
            Call GetWindowRect(GetActiveWindow, tFormRect)
            Call SetProp(Application.hWnd, "hActiveForm", GetActiveWindow)
            Call SetProp(Application.hWnd, "ActiveFormLeft", tFormRect.Left)
            Call SetProp(Application.hWnd, "ActiveFormTop", tFormRect.Top)
        End If
    End If
 
    Set CmbrsEvents = Nothing
    If AreAllFormsOffScreen(tUnionRect) Then
        Call BringFormsBackToScreen(tUnionRect)
    End If
    Set CmbrsEvents = Application.CommandBars

    Call IUnknown_GetWindow(UFEvents, VarPtr(hThisForm))
    If CBool(IsWindow(GetWindowLong(hThisForm, GWL_USERDATA))) = False And _
        bFisrtLayoutEventRun = False Then
            Unload UFEvents
    End If
 
    If GetFocus = GetWindowLong(hThisForm, GWL_USERDATA) Then
        Call SendMessage(hThisForm, WM_NCACTIVATE, True, 0)
    End If

    PreventSleepMode = True
 
    Application.CommandBars.FindControl(ID:=2040).Enabled = _
        Not Application.CommandBars.FindControl(ID:=2040).Enabled
End Sub

Private Sub UFEvents_Layout()

    Const GWL_USERDATA = (-21)
    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const SWP_NOSIZE = &H1
    Const SWP_NOZORDER = &H4
    Const BM_GETCHECK = &HF0
    Const BST_CHECKED = &H1
    #If Win64 Then
        Dim hForm As LongLong
        Dim lCheckBoxState1 As LongLong, lCheckBoxState2 As LongLong
    #Else
        Dim hForm As Long
        Dim lCheckBoxState1 As Long, lCheckBoxState2 As Long
    #End If
    Dim oForm As UserForm
    Dim XOffset As Long, YOffset As Long
    Dim tActiveFormRect As RECT, tRect As RECT
 
    Call IUnknown_GetWindow(UFEvents, VarPtr(hThisForm))
    If GetActiveWindow <> hThisForm Then
        GoTo Xit
    End If

    Set CmbrsEvents = Application.CommandBars
    Call CmbrsEvents_OnUpdate

    If bFisrtLayoutEventRun Then
        Call EnableGrouping(UFEvents)
        bFisrtLayoutEventRun = False
        GoTo Xit
    End If

    For Each oForm In VBA.UserForms
        Call IUnknown_GetWindow(oForm, VarPtr(hForm))
        Call GetWindowRect(hForm, tRect)
        Call SetCheckButtonsPos(oForm)
        If GetActiveWindow <> hForm Then
            Call GetWindowRect(GetActiveWindow, tActiveFormRect)
            XOffset = tActiveFormRect.Left - CLng(GetProp(Application.hWnd, "ActiveFormLeft"))
            YOffset = tActiveFormRect.Top - CLng(GetProp(Application.hWnd, "ActiveFormTop"))
            If IsWindowEnabled(Application.hWnd) Then
                lCheckBoxState1 = SendMessage(GetWindowLong(hForm, GWL_USERDATA), BM_GETCHECK, 0, 0)
                lCheckBoxState2 = SendMessage(GetWindowLong(GetActiveWindow, GWL_USERDATA), BM_GETCHECK, 0, 0)
                If lCheckBoxState1 = BST_CHECKED And lCheckBoxState2 = BST_CHECKED Then
                    With tRect
                        Call SetWindowPos(hForm, 0&, .Left + XOffset, .Top + YOffset, _
                                0&, 0&, SWP_NOACTIVATE + SWP_SHOWWINDOW + SWP_NOZORDER + SWP_NOSIZE)
                    End With
                End If
            End If
        End If
    Next oForm

Xit:
    Call GetWindowRect(GetActiveWindow, tRect)
    Call SetProp(Application.hWnd, "ActiveFormLeft", tRect.Left)
    Call SetProp(Application.hWnd, "ActiveFormTop", tRect.Top)

End Sub

Private Function PivotFormPos(ByVal Q As QUADRANT) As PIVOT_FORM

    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
    Dim tFormRect As RECT
    Dim tPV As PIVOT_FORM
    Dim oForm As UserForm

    With tPV
        For Each oForm In VBA.UserForms
            Call IUnknown_GetWindow(oForm, VarPtr(hForm))
            Call GetWindowRect(hForm, tFormRect)
            Select Case Q
                Case Is = °LEFT
                    If tFormRect.Left >= .RC.Left Or .RC.Left = 0 Then
                        .hWnd = hForm
                        .RC.Left = tFormRect.Left
                        .RC.Right = tFormRect.Right
                    End If
                Case Is = °RIGHT
                    If tFormRect.Left <= .RC.Left Or .RC.Left = 0 Then
                        .hWnd = hForm
                        .RC.Left = tFormRect.Left
                        .RC.Right = tFormRect.Right
                    End If
                Case Is = °TOP
                    If tFormRect.Top >= .RC.Top Or tPV.RC.Top = 0 Then
                        .hWnd = hForm
                        .RC.Top = tFormRect.Top
                        .RC.Bottom = tFormRect.Bottom
                    End If
                Case Is = °BOTTOM
                    If tFormRect.Top <= .RC.Top Or tPV.RC.Top = 0 Then
                        .hWnd = hForm
                        .RC.Top = tFormRect.Top
                        .RC.Bottom = tFormRect.Bottom
                    End If
            End Select
        Next oForm
        PivotFormPos.hWnd = .hWnd
        PivotFormPos.RC = .RC
    End With

End Function

Private Sub SetCheckButtonsPos(ByVal ParentUserForm As UserForm)
    Const GWL_USERDATA = (-21)
    Const HWND_NOTOPMOST = -2
    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const DT_CALCRECT = &H400

    #If Win64 Then
        Dim hWnd As LongLong, hDC As LongLong
    #Else
        Dim hWnd As Long, hDC As Long
    #End If
    Dim tCloseButtonRect As RECT, tTextRect As RECT
 
    Call IUnknown_GetWindow(ParentUserForm, VarPtr(hWnd))
    If IsWindowVisible(hWnd) Then
        tCloseButtonRect = GetCloseButtonRect(ParentUserForm)
        hDC = GetDC(GetWindowLong(hWnd, GWL_USERDATA))
        Call DrawText(hDC, StrPtr(ChrW(9724) & "GRP"), Len(ChrW(9724) & "GRP"), tTextRect, DT_CALCRECT)
        Call ReleaseDC(GetWindowLong(hWnd, GWL_USERDATA), hDC)
        With tTextRect
            Call SetWindowPos(GetWindowLong(hWnd, GWL_USERDATA), HWND_NOTOPMOST, _
                tCloseButtonRect.Left - 1.6 * (.Right - .Left), tCloseButtonRect.Top + 2, _
                1.6 * (.Right - .Left), tCloseButtonRect.Bottom - tCloseButtonRect.Top - 4, _
                SWP_NOACTIVATE + SWP_SHOWWINDOW)
        End With
    End If
End Sub

#If Win64 Then
    Private Function GetTitleBarAcc(ByVal hWnd As LongLong) As IAccessible
#Else
    Private Function GetTitleBarAcc(ByVal hWnd As Long) As IAccessible
#End If

    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_TITLEBAR = -2
    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_TITLEBAR, VarPtr(tGUID(0)), oIAc) = S_OK Then
           Set GetTitleBarAcc = oIAc
        End If
    End If

End Function

Private Function IsAeroEnabled() As Boolean
    Dim bEnabled As Long
    Call DwmIsCompositionEnabled(bEnabled)
    IsAeroEnabled = CBool(bEnabled)
End Function

Private Sub EnableGrouping(ByVal UF As UserForm)

    Const GWL_HWNDPARENT = (-8)
    Const GWL_USERDATA = (-21)
    Const WS_EX_LAYERED = &H80000
    Const WS_EX_NOACTIVATE = &H8000000
    Const LWA_COLORKEY = &H1
    Const COLOR_WINDOW = 5
    Const COLOR_BTNFACE = 15
    Const WS_VISIBLE = &H10000000
    Const WS_POPUP = &H80000000
    Const WS_BORDER = &H800000
    Const BS_AUTOCHECKBOX = &H3&
    Const BS_RIGHTBUTTON = &H20
    Const BS_VCENTER As Long = &HC00
    Const WM_NCACTIVATE = &H86

    #If Win64 Then
        Dim hWnd As LongLong, hButton As LongLong
    #Else
        Dim hWnd As Long, hButton As Long
    #End If
    Dim tFormRect As RECT
    Dim lWinStyle As Long, lWinExStyle As Long, lNewColor As Long
 
    Call IUnknown_GetWindow(UF, VarPtr(hWnd))
    lWinStyle = WS_POPUP + WS_VISIBLE + BS_RIGHTBUTTON + BS_VCENTER + BS_AUTOCHECKBOX + WS_BORDER
    lWinExStyle = WS_EX_NOACTIVATE + IIf(IsAeroEnabled, WS_EX_LAYERED, 0)

    hButton = CreateWindowEx(lWinExStyle, StrPtr("BUTTON"), StrPtr(ChrW(9724) & "GRP"), _
                lWinStyle, 0&, 0&, 0&, 0&, 0&, 0&, GetModuleHandle(vbNullString), ByVal 0&)
    Call TranslateColor(GetSysColor(COLOR_BTNFACE), 0, lNewColor)
    Call SetLayeredWindowAttributes(hButton, lNewColor, 0, LWA_COLORKEY)
 
    Call SetWindowLong(hButton, GWL_HWNDPARENT, hWnd)
    Call SetWindowLong(hWnd, GWL_USERDATA, hButton)
    Call SetWindowLong(hButton, GWL_USERDATA, hWnd)
 
    Call SetCheckButtonsPos(UF)
 
    If GetFocus = hButton Then
        Call SendMessage(hWnd, WM_NCACTIVATE, True, 0)
    End If
 
End Sub

#If Win64 Then
    Private Function IsFormOffScreen(ByVal hForm As LongLong) As Boolean
#Else
    Private Function IsFormOffScreen(ByVal hForm As Long) As Boolean
#End If
    Const SPI_GETWORKAREA = 48
    Dim tFormRect As RECT, tScreenRect As RECT, tIntersectRect As RECT

    Call SystemParametersInfo(SPI_GETWORKAREA, 0&, tScreenRect, 0&)
    Call GetWindowRect(hForm, tFormRect)
    If IntersectRect(tIntersectRect, tFormRect, tScreenRect) = 0 Then
        IsFormOffScreen = True
    End If
End Function

Private Sub BringFormsBackToScreen(tUniontRect As RECT)

    Const SWP_SHOWWINDOW = &H40
    Const SWP_NOACTIVATE = &H10
    Const SWP_NOSIZE = &H1
    Const SWP_NOZORDER = &H4
    Const SPI_GETWORKAREA = 48
    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
    Dim tPVLeft As PIVOT_FORM, tPVRight As PIVOT_FORM
    Dim tPVTop As PIVOT_FORM, tPVBottom As PIVOT_FORM
    Dim tScreenRect As RECT, tFormRect As RECT
    Dim oForm As UserForm
    Dim lNewLeft As Long, lNewTop As Long
 

    tPVLeft = PivotFormPos(°LEFT)
    tPVRight = PivotFormPos(°RIGHT)
    tPVTop = PivotFormPos(°TOP)
    tPVBottom = PivotFormPos(°BOTTOM)
          
    Call SystemParametersInfo(SPI_GETWORKAREA, 0&, tScreenRect, 0&)
 
    For Each oForm In VBA.UserForms
        Call IUnknown_GetWindow(oForm, VarPtr(hForm))
        Call GetWindowRect(hForm, tFormRect)
        With tFormRect
            lNewLeft = .Left
            lNewTop = .Top
            If tUniontRect.Left >= tScreenRect.Right Then
                If hForm = tPVRight.hWnd Then
                    lNewLeft = tScreenRect.Right - (.Right - .Left)
                Else
                    lNewLeft = .Left - (tPVRight.RC.Left - tScreenRect.Right) - _
                        (tPVRight.RC.Right - tPVRight.RC.Left)
                End If
            End If
            If tUniontRect.Top >= tScreenRect.Bottom Then
                If hForm = tPVBottom.hWnd Then
                    lNewTop = tScreenRect.Bottom - (.Bottom - .Top)
                Else
                    lNewTop = .Top - (tPVBottom.RC.Top - tScreenRect.Bottom) - _
                        (tPVBottom.RC.Bottom - tPVBottom.RC.Top)
                End If
            End If
            If tUniontRect.Right < 0 Then
                If hForm = tPVLeft.hWnd Then
                    lNewLeft = 0
                Else
                    lNewLeft = .Left - (tPVLeft.RC.Right) + (tPVLeft.RC.Right - tPVLeft.RC.Left)
                End If
            End If
            If tUniontRect.Top < 0 Then
                If hForm = tPVTop.hWnd Then
                    lNewTop = 0
                Else
                    lNewTop = .Top - (tPVTop.RC.Bottom) + (tPVTop.RC.Bottom - tPVTop.RC.Top)
                End If
            End If
        End With
        Call SetWindowPos(hForm, 0&, lNewLeft, lNewTop, _
        0&, 0&, SWP_NOACTIVATE + SWP_SHOWWINDOW + SWP_NOZORDER + SWP_NOSIZE)
    Next oForm
  
End Sub

Private Function GetCloseButtonRect(ByVal UF As UserForm) As RECT
    Const STATE_SYSTEM_INVISIBLE = &H8000&
    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
    Dim oAcc As IAccessible, vAccChildren As Variant
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim i As Long

    Call IUnknown_GetWindow(UF, VarPtr(hForm))
    Set oAcc = GetTitleBarAcc(hForm)
    Do
        i = i + 1
        Call AccessibleChildren(oAcc, 0&, 1&, vAccChildren, 0&)
        If oAcc.accState(i) <> STATE_SYSTEM_INVISIBLE Then
            oAcc.accLocation lLeft, lTop, lWidth, lHeight, 5&
            Call SetRect(GetCloseButtonRect, lLeft, lTop, lWidth + lLeft, lHeight + lTop)
            Exit Do
        End If
    Loop Until i > oAcc.accChildCount
End Function

Private Function AreAllFormsOffScreen(tUniontRect As RECT) As Boolean

    Const SM_CYCAPTION = 4
    Const SM_CYBORDER = 6
    Const SM_CYDLGFRAME = 8
    Const SM_CYEDGE = 46
    Const SM_CYFIXEDFRAME = 8
    Const SPI_GETWORKAREA = 48

    #If Win64 Then
        Dim hForm As LongLong
    #Else
        Dim hForm As Long
    #End If
 
    Dim tFormRect As RECT, tScreenRect As RECT, tOutRect As RECT
    Dim oForm As UserForm

    If GetAsyncKeyState(VBA.vbKeyLButton) = 0 Then
        Call SystemParametersInfo(SPI_GETWORKAREA, 0&, tScreenRect, 0&)
        With tScreenRect
            .Left = .Left + GetSystemMetrics(SM_CYCAPTION)
            .Bottom = .Bottom - GetSystemMetrics(SM_CYCAPTION)
            .Right = .Right - GetSystemMetrics(SM_CYCAPTION)
        End With
        For Each oForm In VBA.UserForms
            Call IUnknown_GetWindow(oForm, VarPtr(hForm))
            Call GetWindowRect(hForm, tFormRect)
            Call UnionRect(tUniontRect, tUniontRect, tFormRect)
        Next oForm
        If IntersectRect(tOutRect, tUniontRect, tScreenRect) = 0 Then
            AreAllFormsOffScreen = True
        End If
    End If

End Function

Private Property Let PreventSleepMode(ByVal bPrevent As Boolean)
    Const ES_SYSTEM_REQUIRED As Long = &H1
    Const ES_DISPLAY_REQUIRED As Long = &H2
    Const ES_AWAYMODE_REQUIRED = &H40
    Const ES_CONTINUOUS As Long = &H80000000
 
    If bPrevent Then
        Call SetThreadExecutionState(ES_CONTINUOUS Or ES_DISPLAY_REQUIRED Or ES_SYSTEM_REQUIRED Or ES_AWAYMODE_REQUIRED)
    Else
        Call SetThreadExecutionState(ES_CONTINUOUS)
    End If
End Property

2- Code Usage in the UserForm Module:

VBA Code:

Option Explicit

Private oGroup As CGroup

Private Sub UserForm_Initialize()
    Set oGroup = New CGroup
    oGroup.AttachForm Me
End Sub

Jaafar Tribak · Sep 30, 2022

UserFormsGrouping_V2_WithoutTimer.xlsm

Just a small addition to the class in order to provide 2 custom events ( OnGroup and OnUnGroup )

The 2 events can be sinked into the UserForm Module as follows :

VBA Code:

Private Sub oGroup_OnGroup()
    Debug.Print "Grouped : ", Me.Name, Format(Now, "hh:mm:ss")
End Sub

Private Sub oGroup_OnUnGroup()
    Debug.Print "UnGrouped : ", Me.Name, Format(Now, "hh:mm:ss")
End Sub

Code added to the Class :

VBA Code:

Private Sub EventRaiser()
    Const GWL_USERDATA = (-21)
    Const BM_GETCHECK = &HF0
    Const BST_CHECKED = &H1
    
    Static lPrevCheckBoxState As Long
    Dim lCheckBoxState As Long
    
    lCheckBoxState = CLng(SendMessage(GetWindowLong(hThisForm, GWL_USERDATA), BM_GETCHECK, 0, 0))
    If lCheckBoxState <> lPrevCheckBoxState Then
        If lCheckBoxState = BST_CHECKED Then
            RaiseEvent OnGroup
        Else
            RaiseEvent OnUnGroup
        End If
    End If
    lPrevCheckBoxState = lCheckBoxState
End Sub

Grouping UserForms [Having userforms follow each other when moved around the screen]

Jaafar Tribak

Well-known Member

Excel Facts

Dan_W

Well-known Member

Tom.Jones

Well-known Member

Jaafar Tribak

Well-known Member

Dan_W

Well-known Member

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

Grouping UserForms [Having userforms follow each other when moved around the screen]

Jaafar Tribak

Well-known Member

Excel Facts

Dan_W

Well-known Member

Tom.Jones

Well-known Member

Jaafar Tribak

Well-known Member

Dan_W

Well-known Member

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock