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
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