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 < 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:
FormFocusListener Class:
FocusListener Support Module:
I have tried to sub-class the user forms using modified code 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 SubFormFocusListener Class:
Code:
Option Explicit
Public Event ChangeFocus(ByVal gotFocus As Boolean)
Public Property Let ChangeFocusMessage(ByVal gotFocus As Boolean)
RaiseEvent ChangeFocus(gotFocus)
End PropertyFocusListener 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
