Catching the Mouse Click Error in Modal User Form

huiettcm · #1 02-09-2024, 09:12 AM

Good morning! I'll start with the the goal. I have an excel workbook for data collection. The user can enter data using a form. The user can also edit entries, which brings the data back into the form. I'd like the user to be able to open multiple forms at once. The issue is that the mouse scroll requires a Modal user form and opening multiple forms is a Modeless function. The solution is to have to 'top' form as Modal while the other forms behind are Modeless. Now I have to switch the user forms between the two states.

I have tried to sub-class the user forms using modified code found <404 - File or directory not found.. This didn't work because in Modal the user forms throw an error when clicked outside the form window. The activate message never gets sent. This method crashes excel. I've also tried GetWindowPos through the Windows API. This also didn't work because that's an application level function.

Currently, there is a Userform_Click() event that works. When a user clicks in the form window but outside the user form, the form is redrawn as vbModeless and vice versa. This isn't very intuitive.

Since the focusListener doesn't work, I've included that code. I'll also include the click event for good measure. There are public variables included that are not declared or set in this code. This project has a lot of code, so I won't attach the file. But the question is.....

How do I catch the error excel throws when a user clicks outside a Modal user form, so in the error handling I can redraw the user form as Modeless?

Updates from research: I think this is an critical error thrown by the application. Code is normally suspended when a user form is displayed vbModal so this code has to be in the user form, right? Maybe the sub-class method is the way to go? IDK

User Form Code:

Code:

Option Explicit

Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal index As LongPtr) As LongPtr

Private Declare PtrSafe Function GetDC Lib "user32" _
(ByVal hwnd As LongPtr) As LongPtr

Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As LongPtr, ByVal nIndex As LongPtr) As LongPtr

Private Declare PtrSafe Function ReleaseDC Lib "user32" _
(ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As LongPtr

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 FindWindow Lib "user32" _
    Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As LongPtr

Private Const HWND_TOP = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2

Private Const LOGPIXELSX = 88 'Pixels/inch in X

'A point is defined as 1/72 inches
Private Const POINTS_PER_INCH As LongPtr = 72

'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 longs, one for x value and one for y value
Private Type POINTAPI
    X_Pos As Long
    Y_Pos As Long
End Type

Public Function PointsPerPixel() As Double
'The size of a pixel, in points
    Dim hdc As LongPtr
    Dim lDotsPerInch As LongPtr
    hdc = GetDC(0)
    lDotsPerInch = GetDeviceCaps(hdc, LOGPIXELSX)
    PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
    ReleaseDC 0, hdc
End Function

Public Sub UserForm_Initialize()

Dim ctrl As Control
Dim i
Dim fnd As Boolean
Dim nf As DE_Form

Dim w As LongPtr, h As LongPtr, p As Double, col As Long

w = GetSystemMetrics(0) ' Screen Resolution width in points
h = GetSystemMetrics(1) ' Screen Resolution height in points

'sets screen position, height, width, zoom, and scroll bars
With Me
    
    'sets width
    If CDbl(w * PointsPerPixel * 0.75) > (Me.DataEntryGroup_Label.Width + 150) Then
        .Width = Me.DataEntryGroup_Label.Width + 150
    Else
        .Width = w * PointsPerPixel * 0.75               'Userform width= Width in Resolution * DPI * %
    End If
    
    'sets height
    .Height = h * PointsPerPixel * 0.9                  'Userform height= Height in Resolution * DPI * %
    
    'sets left
    If lft = 0 Then
        lft = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
    End If
    
    'sets top
    If tp = 0 Then
        tp = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
    End If
    
    'sets position for empty forms
    .StartUpPosition = 0
    .Left = lft
    .Top = tp
    
    .Zoom = (Me.Width / Me.DataEntryGroup_Label.Width) * 95
    .ScrollBars = fmScrollBarsVertical
    .ScrollHeight = Me.DataEntryGroup_Label.Height + 25
    .ScrollWidth = Me.DataEntryGroup_Label.Width + 25
    .ScrollTop = 0
End With

'****Bunch of code assigning form dropdown options, etc.

' Set our event extender
Set focusListener = New FormFocusListener

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

End Sub

Private Sub UserForm_Activate()

If Me.Tag = "Modal" Then
    EnableMouseScroll Me
End If

ConvertToWindow

End Sub

Private Sub UserForm_Click()

Dim hold As POINTAPI
Dim i
Dim nf As DE_Form

GetCursorPos hold
lft = Me.Left
tp = Me.Top

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

End Sub

Private Sub focusListener_ChangeFocus(ByVal gotFocus As Boolean)
Dim tn As String, AC As Chart
If gotFocus Then
   On Error Resume Next    
    Select Case Me.Tag
    Case Is = "Modeless":
        For i = 1 To editcoll.Count
            If Me.Caption = editcoll(i).Caption Then
                editcoll.Remove i
                Exit For
            End If
        Next i
        
        Me.Hide
        Me.Tag = "Modal"
        editcoll.Add Me, Key:=Me.Caption
        
        Me.Show vbModal
        
        EnableMouseScroll Me
        ConvertToWindow
    Case Is = "Modal":
        DisableMouseScroll Me
        
        For i = 1 To editcoll.Count
            If Me.Caption = editcoll(i).Caption Then
                editcoll.Remove i
                Exit For
            End If
        Next i
        
        Me.Hide
        Me.Tag = "Modeless"
        editcoll.Add Me, Key:=Me.Caption
        
        Me.Show vbModeless
    End Select
    On Error GoTo 0
End If
End Sub

FormFocusListener Class:

Code:

Option Explicit

Public Event ChangeFocus(ByVal gotFocus As Boolean)

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

FocusListener Support Module:

Code:

Option Explicit

#If VBA7 Then
    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
    #If Win64 Then
        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" _
            Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Public Declare Function SetWindowLongPtr Lib "user32" _
            Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
    Public lPrevWnd As LongPtr
#Else
    Public Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Public 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
    Public Declare Function SetWindowLong Lib "user32" _
        Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Public lPrevWnd As Long
#End If

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

Public tf As DE_Form

#If VBA7 Then
Public Function myWindowProc(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr
#Else
Public Function myWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
    ' 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 Msg
            Debug.Print Msg
            Case WM_NULL ' sent when clicked outside modal userform
                
                'tf.focusListener.ChangeFocusMessage = wParam ' TRUE if border has been activated
                'myWindowProc = CallWindowProc(lPrevWnd, hWnd, Msg, wParam, ByVal lParam)
            Case WM_DESTROY
                ' Form is closing, so remove subclassing
                #If VBA7 Then
                    'Call SetWindowLongPtr(hWnd, GWL_WNDPROC, lPrevWnd)
                #Else
                    'Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevWnd)
                #End If
                'myWindowProc = 0
            Case Else
                'myWindowProc = CallWindowProc(lPrevWnd, hWnd, Msg, wParam, ByVal lParam)
        End Select
    On Error GoTo 0
End Function 'myWindowProc

huiettcm · #2 02-13-2024, 12:18 PM

Solved with an update for the mouse scroll controller/class. Original incorporation of Christian Buse's code did not include a modeless user form. Now it does. So the problem is moot. Updated code found below.

<https://github.com/cristianbuse/VBA-UserForm-MouseScroll>

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Start animation on left mouse click, stop animation when left mouse click is released. Possible?	pbyrescue	PowerPoint	0	03-23-2023 06:25 AM
PPT Slides Do Not Advance w/ Mouse Click	TimC	PowerPoint	2	03-15-2018 09:26 AM
Show images on mouse-over or mouse-click	Sev	Drawing and Graphics	2	08-04-2017 07:28 AM
Transition : timings AND mouse click	Iluvsodah	PowerPoint	1	02-21-2013 05:14 PM
Mouse over or click highlighting	SavageMind	PowerPoint	1	03-19-2012 01:58 PM