CODEWITHSUNDEEP
excelvbauserform
Chris H.
Chris H.

Reputation: 325

Event Listener for UserForm Focus

I'm trying to get an event listener to determine which userform 'has focus'. I'm adapting code found here: https://www.tek-tips.com/viewthread.cfm?qid=1747946.

The goal is to open multiple instances of a userforms and have the active form be vbmodal so I can hook the mouse wheel to that form and its controls. When the user clicks on a different instance of the userform, that one gets a .Hide and a .Show vbModal and the previous instance gets reshown as vbModeless.

The user can select 1 or multiple rows of data to be edited. Each entry gets put into a collection of userforms, editcoll. I open each form in the collection vbModeless and let the focus event take over.

The problem is that when excel is trying to open the forms, the application crashes. I can't set a breakpoint in the UF without excel crashing. I have commented out the focusListener_ChangeFocus() sub and excel still crashes. If I comment out all of this, it works of course. I don't know what is going on. Any help is greatly appreciated.

Here's what I've got so far: A simple class called FormFocusListener

Option Explicit

Public Event ChangeFocus(ByVal gotFocus As Boolean)

Public Property Let ChangeFocusMessage(ByVal gotFocus As Boolean)
    RaiseEvent ChangeFocus(gotFocus)
End Property

A support module with the following:

Option Explicit

Public Declare PtrSafe Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function CallWindowProc Lib "user32" _
    Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" _
    Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Public lPrevWnd As LongPtr

Private Const WM_NCACTIVATE = &H86
Private Const WM_DESTROY = &H2
Public Const GWL_WNDPROC = (-4)

Public Function myWindowProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr

    ' This function intercepts window events from the CopyCurveForm and initiates
    ' a ChangeFocus event for the FormFocusListener class object.
    On Error Resume Next ' an unhandled error in message loop may crash xl so let's ignore it (normally not best practice)
        Select Case uMsg
            Case WM_NCACTIVATE ' sent when window border activates OR deactivates
                DE_Form.focusListener.ChangeFocusMessage = wParam ' TRUE if border has been activated
                myWindowProc = CallWindowProc(lPrevWnd, hWnd, uMsg, wParam, ByVal lParam)
            Case WM_DESTROY
                ' Form is closing, so remove subclassing
                Call SetWindowLongPtr(hWnd, GWL_WNDPROC, lPrevWnd)
                myWindowProc = 0
            Case Else
                myWindowProc = CallWindowProc(lPrevWnd, hWnd, uMsg, wParam, ByVal lParam)
        End Select
    On Error GoTo 0
End Function 'myWindowProc

And then in the UserForm:

Option Explicit

Public WithEvents focusListener As FormFocusListener
Public Sub UserForm_Initialize()

'Set our event extender
Set focusListener = New FormFocusListener

'subclass the userform to catch WM_NCACTIVATE msgs
Dim lhWnd As LongPtr

lhWnd = FindWindow("ThunderDFrame", Me.Caption)
lPrevWnd = SetWindowLongPtr(lhWnd, GWL_WNDPROC, myWindowProc) 'AddressOf myWindowProc)

End Sub

Private Sub focusListener_ChangeFocus(ByVal gotFocus As Boolean)

Dim i
Dim nf As DE_Form
Dim ctrl As Control

'userform gets focus, hides and redraws modal, attaches mouse scroll
If gotFocus = True Then
    Me.Hide
    Me.Show vbModal
    EnableMouseScroll Me
End If

'lost focus, saves the current entries into the editcoll collection, disables the mouse and redraws modeless
If Not gotFocus Then
    DisableMouseScroll
    
    For i = 1 To editcoll.Count
        Set nf = editcoll(i)
        
        If Me.Caption = nf.Caption Then
            For Each ctrl In Me
                nf.Controls(ctrl).value = Me.Controls(ctrl).value
            Next ctrl
            Exit For
        End If
    Next i
    
    Me.Hide
    nf.Show vbModeless
End If

End Sub

Upvotes: 1

Views: 88

Answers (1)

Chris H.
Chris H.

Reputation: 325

so what I want to accomplish with this is fundamentally flawed. When multiple user forms are open, and the top form is Modal the other forms are locked. I am fairly certain the WM_NCACTIVATE message can't get sent by clicking on a window's header because they're locked. I solved this with a click event. editcoll is a collection used to house all forms the user selected for editing.

Option Explicit

'Access the GetCursorPos function in user32.dll
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

' GetCursorPos requires a variable declared as a custom data type
' that will hold two integers, one for x value and one for y value
Private Type POINTAPI
    X_Pos As Long
    Y_Pos As Long
End Type

Private Sub UserForm_Click()

Dim hold As POINTAPI
Dim i
Dim nf As DE_Form

GetCursorPos hold
Select Case Me.Tag
Case Is = "Modeless":
    
    If (hold.X_Pos > Me.Left And _
      hold.X_Pos < (Me.Left + Me.Width) * 2) Or _
      (hold.Y_Pos > Me.Top And _
      hold.Y_Pos < (Me.Top + Me.Height) + 100) Then
    
        Me.Hide
        Me.Tag = "Modal"
        
        For i = 1 To editcoll.Count
            If Me.Caption = editcoll(i).Caption Then
                editcoll.Remove i
                editcoll.Add Me, Key:=Me.Caption
                Exit For
            End If
        Next i
        
        Me.Show vbModal
        EnableMouseScroll Me
        ConvertToWindow
        
    End If
Case Is = "Modal":
    
    If hold.X_Pos < Me.Left Or _
      hold.X_Pos > (Me.Left + Me.Width) Or _
      hold.Y_Pos < Me.Top Or _
      hold.Y_Pos > (Me.Top + Me.Height) Then
    
        Me.Hide
        Me.Tag = "Modeless"
        
        For i = 1 To editcoll.Count
            If Me.Caption = editcoll(i).Caption Then
                editcoll.Remove i
                editcoll.Add Me, Key:=Me.Caption
                Exit For
            End If
        Next i
        
        Me.Show vbModeless
    End If
End Select

End Sub

Upvotes: 0

Related Questions