Double click event on form title bar?

[ycgq]

I am using excel 2003. I would like to double click on the form title bar to shrink the form to only show title bar. Double click again will restore the original size. Any idea with Windows API? I searched web and tried but it is not working. Thanks a lot.

 

[Snakehips]

ycgq,

The double click has to be on the area inside the title bar and border.
Does this help....?

Private Sub UserForm_DbClick(ByVal Cancel As MSForms.ReturnBoolean)

If Me.Height < 180 then   '** edit 180 = fullheight of your form
Me.Height = 180
Else: Me.Height = 25
End If
End Sub

 

[ycgq]

Thanks Tony. I still would like to see whether there is a way to double click on the title bar to do this.

 

[ycgq]

Any ideas to catch the form title bar double click event?

 

[Jaafar Tribak]

Workbook example


This should shrink and collapse the userform :

1 - Put this code in the UserForm module

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private lHwnd As Long


Private Sub UserForm_Initialize()

    lHwnd = FindWindow(vbNullString, Me.Caption)
    If lHwnd Then
        SubClass lHwnd, Me.Height, Me
    End If
    
End Sub

Private Sub UserForm_Terminate()

    UnSubClass True

End Sub

2 - Put this code in a Standard Module

Option Explicit

Private Declare Function SetWindowLongA Lib "User32.dll" _
(ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare Function CallWindowProcA Lib "User32.dll" _
(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, _
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_NCLBUTTONDBLCLK    As Long = &HA3&
Private Const HTCAPTION             As Long = &H2&
Private Const GWL_WNDPROC           As Long = (-4)

Private lHwnd     As Long
Private lOldFunc  As Long
Private lHeight   As Single
Private oFrm      As Object


Public Sub SubClass _
(ByVal hWnd As Long, ByVal Hght As Single, ByVal Frm As Object)

  If lHwnd = 0 Then
    lHwnd = hWnd
    lHeight = Hght
    Set oFrm = Frm
    lOldFunc = SetWindowLongA(lHwnd, GWL_WNDPROC, AddressOf lWndProc)
  End If
  
End Sub

Public Sub UnSubClass(dummy As Boolean)

  If lHwnd <> 0 Then
    Call SetWindowLongA(lHwnd, GWL_WNDPROC, lOldFunc)
    lHwnd = 0
    lHeight = 0
    Set oFrm = Nothing
  End If
  
End Sub
 
Private Function lWndProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

    Static x As Long
    Dim y    As Long
    
    If uMsg = WM_NCLBUTTONDBLCLK Then
        If wParam = HTCAPTION Then
            y = x Mod 2
            x = x + 1
            oFrm.Height = Abs(CLng(y <> 0)) * lHeight
        End If
    End If
    lWndProc = CallWindowProcA(lOldFunc, hWnd, uMsg, wParam, lParam)
    
End Function

 

[ycgq]

Thanks Jaafar a lot! This works great. However, when the form is showing in vbModeless, the EXCEL application will hang there. And all my forms are showing vbModeless.

 

[Jaafar Tribak]

Thanks Jaafar a lot! This works great. However, when the form is showing in vbModeless, the EXCEL application will hang there. And all my forms are showing vbModeless.

I am afraid this only works for Modal userforms ..... I'll take another shot at this later on and see if I can come up with something that works for Modeless userforms.

 

[Jaafar Tribak]

After much thinking i came up with this solution which should work for modeless userforms but there are a couple of limitations :
1- You cannot run more than 1 modeless userform at the same time..... In reality one should be able to do so but that would require a timer which would be too much trouble.
2- Because the code uses a loop initiated upon loading the form, any additionnal code must be carefully added around the existing code.

Anyway, here is a Workbook Example


Code goes in the UserForm module :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type Msg
    Hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Declare Function GetMessage Lib "user32" _
    Alias "GetMessageA" (lpMsg As Msg, ByVal Hwnd As Long, _
    ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) 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 Function FindWindow Lib "user32.dll" _
    Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

Private Const WM_NCLBUTTONDBLCLK As Long = &HA3&
Private Const HTCAPTION          As Long = &H2&

Private bFormLoaded As Boolean


Private Sub UserForm_Initialize()
    Dim lHwnd     As Long
    Dim lHeight   As Single

    lHwnd = FindWindow(vbNullString, Me.Caption)
    If lHwnd Then
        Me.Show vbModeless
        lHeight = Me.Height
        bFormLoaded = True
        Call MyMessageLoop(lHwnd, lHeight)
    End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    bFormLoaded = False
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub MyMessageLoop(Hwnd As Long, Height As Single)
    Dim tMsg As Msg
    Dim x As Long

    Do While GetMessage(tMsg, 0, 0, 0) And bFormLoaded = True
        With tMsg
            If .message = WM_NCLBUTTONDBLCLK And .Hwnd = Hwnd And .wParam = HTCAPTION Then
                Me.Height = Abs(CLng(x Mod 2 <> 0)) * Height
                x = x + 1
            End If
            PostMessage .Hwnd, .message, .wParam, .lParam
        End With
        DoEvents
    Loop
End Sub

 

[ycgq]

Thanks Jaafar so much!!!