Extending UserForm capabilities (Min,Max,Restore,Resize and their respective event handlers )

[Jaafar Tribak]

Hi all,

Changing userform styles to add a Max,Min,Restore menu buttons , to make the userform resizeable or to show its icon on the taskbar are techniques we can apply with relative ease with a couple of APIs however associating an event handler for each added functionality is a bit more difficult.

Here, I have made an attempt to add such capabilities while having the focus on the coding design in order to make the setting of the custom Properties and the calling of Methods/Events as easy and as instinctive as possible for the user.

here is a WORKBOOK DEMO.

Basically, the Project makes use of two custom Interfaces . One for changing the userform Styles and one for adding the Custom events.
This ,hopefully, should make building/calling the Custom Userform easier as shown in the example below :


1- In a Standard Module (Caller code)

Option Explicit
 
Sub Test()

    Dim MyForm As UserForm1
    Dim ChangerInterFace As IFormChanger
    Dim SubClasserInterface As IFormSubClasser
    
  [COLOR=seagreen]  'invoque the Default InterFace.
[/COLOR]    Set MyForm = New UserForm1
    
   [COLOR=seagreen] 'invoque the ChangerInterFace.[/COLOR]
    Set ChangerInterFace = MyForm
        
    With ChangerInterFace
        .MinMaxButtons = True
        .TaskBarIcon = True
        .ReSizeable = True
    End With
    
     [COLOR=seagreen]'invoque the EventsInterface.
[/COLOR]    Set SubClasserInterface = MyForm
    
    With SubClasserInterface
        .AttachEvent _
        MaximizeEvent + MinimizeEvent _
        + RestoreEvent + ResizeEvent
    End With
    
    
    MyForm.Show

End Sub
 
Sub UserForm_Maximize(ByRef Cancel As Boolean)
 
    Cancel = True
    MsgBox "You chose not to allow maximizing the form."
 
End Sub
 
Sub UserForm_Minimize(ByRef Cancel As Boolean)
 
    MsgBox "You are minimizing the form."
 
End Sub
 
Sub UserForm_Restore(ByRef Cancel As Boolean)
 
        MsgBox "You are restoring the form."
 
End Sub
 
Sub UserForm_Size(ByRef Cancel As Boolean)
 
    Static bStartedResizing As Boolean
 
    If Not bStartedResizing Then
       MsgBox "You are about to resize the form."
      bStartedResizing = True
    End If
 
End Sub

2- Code for the StyleChanging Interface.

In a Class Module named ( IFormChanger)

Option Explicit
 
Public Property Let MinMaxButtons(ByVal value As Boolean)
End Property
 
Public Property Let ReSizeable(ByVal value As Boolean)
End Property
 
Public Property Let TaskBarIcon(ByVal value As Boolean)
End Property

3- Code for the Events Interface.

In a Class Module named ( IFormSubClasser)

Option Explicit
 
Public Enum TargetEvent
    MaximizeEvent = 1
    MinimizeEvent = 2
    RestoreEvent = 4
    ResizeEvent = 8
End Enum

Public Sub AttachEvent(Event_ As TargetEvent)
End Sub

4- Code in the UserForm Module

Option Explicit
 
Implements IFormChanger
Implements IFormSubClasser
 
Private Property Let IFormChanger_MinMaxButtons _
(ByVal value As Boolean)
 
    If value Then
        Call AddMinMaxButtons(Me)
    End If
 
End Property
 
Private Property Let IFormChanger_TaskBarIcon _
(ByVal value As Boolean)
 
    If value Then
        Call AddTaskBarIcon(value)
    End If
 
End Property
 
Private Property Let IFormChanger_ReSizeable _
(ByVal value As Boolean)
 
    If value Then
        Call MakeFormResizeable(Me)
    End If
    
End Property
 
Private Sub IFormSubClasser_AttachEvent _
(Event_ As TargetEvent)
 
    If Event_ And MaximizeEvent Then Call MaximizeCallBack(Me)
    If Event_ And MinimizeEvent Then Call MinimizeCallBack(Me)
    If Event_ And RestoreEvent Then Call RestoreCallBack(Me)
    If Event_ And ResizeEvent Then Call ResizeCallBack(Me)
 
End Sub

5- And finally here is the meat of the code

In a Standard module (Main Code)

Option Explicit
 
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
    ByVal lpfn As Long, _
    ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
    (ByVal hHook As Long, _
    ByVal ncode As Long, _
    ByVal wParam As Long, _
lParam As Any) 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 CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As Long, _
    ByVal hwnd As Long, _
    ByVal msg As Long, _
    ByVal wParam As Long, _
ByVal lParam 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 FindWindow Lib "user32" _
Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) _
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 DrawMenuBar _
Lib "user32" ( _
    ByVal hwnd As Long) _
As Long
 
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" _
    (ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long

Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = -20
Private Const GWL_WNDPROC   As Long = -4
 
Private Const WS_SIZEBOX As Long = &H40000
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_EX_APPWINDOW As Long = &H40000

Private Const WM_SYSCOMMAND As Long = &H112
Private Const SC_MAXIMIZE As Long = &HF030&
Private Const SC_MINIMIZE As Long = &HF020&
Private Const SC_RESTORE As Long = &HF120&
Private Const WM_NCLBUTTONDBLCLK As Long = &HA3
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_SIZING As Long = &H214
Private Const WM_DESTROY As Long = &H2
 
Private bMaximizeEventSet  As Boolean
Private bMinimizeEventSet  As Boolean
Private bRestoreEventSet  As Boolean
Private bResizeEventSet  As Boolean
Private bMoving  As Boolean
 
Private lhHook As Long
Private lOldWinProc As Long
 
Public Sub AddMinMaxButtons(Form As Object)
 
    Dim lFrmhwnd As Long
    Dim lStyle As Long
    
    lFrmhwnd = FindWindow(vbNullString, Form.Caption)
    
    lStyle = GetWindowLong(lFrmhwnd, GWL_STYLE)
    lStyle = lStyle Or WS_SYSMENU
    lStyle = lStyle Or WS_MINIMIZEBOX
    lStyle = lStyle Or WS_MAXIMIZEBOX
    
    SetWindowLong lFrmhwnd, GWL_STYLE, (lStyle)
    DrawMenuBar lFrmhwnd

End Sub

Public Sub AddTaskBarIcon(Dummy As Variant)
 
    Dim lFrmhwnd As Long
    
    lhHook = SetWindowsHookEx _
    (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
 
End Sub
 
Public Sub MakeFormResizeable(Form As Object)
 
    Dim lFrmhwnd As Long
    Dim lStyle As Long
    
    lFrmhwnd = FindWindow(vbNullString, Form.Caption)
    lStyle = GetWindowLong(lFrmhwnd, GWL_STYLE)
    lStyle = lStyle Or WS_SIZEBOX
    SetWindowLong lFrmhwnd, GWL_STYLE, (lStyle)

End Sub
 
Public Sub MaximizeCallBack(Form As Object)
 
    bMaximizeEventSet = True
    Call SubClassForm(Form)
 
End Sub
 
Public Sub MinimizeCallBack(Form As Object)
 
    bMinimizeEventSet = True
    Call SubClassForm(Form)
 
End Sub
 
Public Sub RestoreCallBack(Form As Object)
 
    bRestoreEventSet = True
    Call SubClassForm(Form)
 
End Sub
 
Public Sub ResizeCallBack(Form As Object)
 
    bResizeEventSet = True
    Call SubClassForm(Form)
 
End Sub
 

Private Sub SubClassForm(Form As Object)
 
    Dim lFrmhwnd As Long
    
    lFrmhwnd = FindWindow(vbNullString, Form.Caption)
    If lOldWinProc = 0 Then
        lOldWinProc = _
        SetWindowLong(lFrmhwnd, GWL_WNDPROC, AddressOf WindowProc)
    End If
 
End Sub

Private Function WindowProc _
(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
 
    Dim bcancel As Boolean
    
    Select Case uMsg
    
        Case WM_SYSCOMMAND
            bMoving = False
            If wParam = SC_MAXIMIZE And bMaximizeEventSet Then
                bMoving = True
                Call UserForm_Maximize(bcancel)
                If bcancel Then Exit Function
            End If
            If wParam = SC_MINIMIZE And bMinimizeEventSet Then
                bMoving = True
                Call UserForm_Minimize(bcancel)
                If bcancel Then Exit Function
            End If
            If wParam = SC_RESTORE And bRestoreEventSet Then
                bMoving = True
                Call UserForm_Restore(bcancel)
                If bcancel Then Exit Function
            End If
        Case WM_SIZING
            If bResizeEventSet Then
                Call UserForm_Size(bcancel)
                If Not bMoving Then
                    If bcancel Then _
                    PostMessage hwnd, WM_LBUTTONUP, 0, 0
                End If
            End If
        Case WM_NCLBUTTONDBLCLK
            Exit Function
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lOldWinProc
            lOldWinProc = 0
            bMaximizeEventSet = False
            bMinimizeEventSet = False
            bRestoreEventSet = False
            bResizeEventSet = False
            bMoving = False
            
    End Select
    
    'pass msgs to the def window proc.
    WindowProc = CallWindowProc _
    (lOldWinProc, hwnd, uMsg, wParam, lParam)
 
End Function

Private Function HookProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
    Dim sBuffer As String
    Dim lRetVal As Long
    Dim lEXStyle As Long
 
    If idHook = HCBT_ACTIVATE Then
        sBuffer = Space(256)
        lRetVal = GetClassName(wParam, sBuffer, 256)
        If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _
        Left(sBuffer, lRetVal) = "ThunderXFrame" Then
            lEXStyle = GetWindowLong(wParam, GWL_EXSTYLE)
            lEXStyle = lEXStyle Or WS_EX_APPWINDOW
            SetWindowLong wParam, GWL_EXSTYLE, (lEXStyle)
            UnhookWindowsHookEx lhHook
        End If
    End If
    
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal wParam, ByVal lParam)
 
End Function

Tested on Win XP excel 2003 only.

Hope this to be found useful. Any comments or suggestions most welcome.


Regards.