Trying to run code but it crashes.

D

dagda13

Board Regular
Joined
May 18, 2019
Messages
52
Hi, I recently found an excellent post by Jaafar Tribak on scrolling down ComboBox drop downs with the mouse wheel. I've tried running the following code.

This is the code attached to my ComboBox (CombBox9):

Option Explicit

Private Sub ComboBox9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Call SetComboBoxHook(ComboBox9)
End Sub

Private Sub ComboBox9_LostFocus()
Call RemoveComboBoxHook
End Sub

Private Sub ComboBox9_Change()
'change event not affected by the hook.
End Sub

-------------------------

And this is the code in my other module (Module2):

Option Explicit

Type POINTAPI
x As Long
y As Long
End Type

Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type

#If VBA7 Then
#If Win64 Then
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
#Else
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Dim hwnd As LongPtr, lMouseHook As LongPtr
#Else
Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
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
Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Dim hwnd As Long, lMouseHook As Long
#End If

Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const MK_LBUTTON = &H1
Const SM_CXVSCROLL = 2

Dim oComboBox As Object

Sub SetComboBoxHook(ByVal Control As Object)
Dim tpt As POINTAPI
Dim sBuffer As String
Dim lRet As Long

Set oComboBox = Control
RemoveComboBoxHook
GetCursorPos tpt
#If VBA7 And Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, tpt, LenB(tpt)
hwnd = WindowFromPoint(lPt)
#Else
hwnd = WindowFromPoint(tpt.x, tpt.y)
#End If
sBuffer = Space(256)
lRet = GetClassName(GetParent(hwnd), sBuffer, 256)
If InStr(Left(sBuffer, lRet), "MdcPopup") Then
SetFocus hwnd
#If VBA7 Then
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
#Else
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
#End If
End If
End Sub

Sub RemoveComboBoxHook()
UnhookWindowsHookEx lMouseHook
End Sub


#If VBA7 Then
Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End If

Dim sBuffer As String
Dim lRet As Long
Dim tRect As RECT

sBuffer = Space(256)
lRet = GetClassName(GetActiveWindow, sBuffer, 256)
If Left(sBuffer, lRet) = "wndclass_desked_gsk" Then Call RemoveComboBoxHook
If IsWindow(hwnd) = 0 Then Call RemoveComboBoxHook

If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
#If VBA7 And Win64 Then
Dim lPt As LongPtr
Dim Low As Long, High As Long
Dim lParm As LongPtr
CopyMemory lPt, lParam.pt, LenB(lPt)
If WindowFromPoint(lPt) = hwnd Then
#Else
Dim Low As Integer, High As Integer
Dim lParm As Long
If WindowFromPoint(lParam.pt.x, lParam.pt.y) = hwnd Then
#End If
GetClientRect hwnd, tRect
If lParam.mouseData > 0 Then
Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
lParm = MakeLong_32_64(Low, High)
Else
Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
High = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
lParm = MakeLong_32_64(Low, High)
End If
PostMessage hwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm
PostMessage hwnd, WM_LBUTTONUP, MK_LBUTTON, lParm
End If
End If
End If

MouseProc = CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
End Function

#If VBA7 And Win64 Then
Function MakeLong_32_64(ByVal wLow As Long, ByVal wHigh As Long) As LongPtr
Dim retVal As LongPtr, b(3) As Byte

MoveMemory ByVal VarPtr(b(0)), ByVal VarPtr(wLow), 4
MoveMemory ByVal VarPtr(b(2)), ByVal VarPtr(wHigh), 4
MoveMemory ByVal VarPtr(retVal), ByVal VarPtr(b(0)), 8
MakeLong_32_64 = retVal
#Else
Function MakeLong_32_64(ByVal wLow As Integer, ByVal wHigh As Integer) As Long
Dim retVal As Long, b(3) As Byte

MoveMemory ByVal VarPtr(b(0)), ByVal VarPtr(wLow), 2
MoveMemory ByVal VarPtr(b(2)), ByVal VarPtr(wHigh), 2
MoveMemory ByVal VarPtr(retVal), ByVal VarPtr(b(0)), 4
MakeLong_32_64 = retVal
#End If
End Function


-----------------------------------------

The code actually works for a few seconds, but then crashes. I get the following error:

Run-time error '91':

Object variable or With block variable not set.

When I run the Debugger, the following code is highlighed in my ComboBox9 code:

Private Sub ComboBox9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Call SetComboBoxHook(ComboBox9)
End Sub

I've tried to find the error, but no luck.
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
Hi dagda13,

Is the combobox embedded on a worksheet or placed on a userform ?

And what version of excel are you using as well as the windows version ?

I am logging off shortly but i'll take a look later.
 
Upvote 0
Hi Jaafar,

Thanks very much for the help! The combobox is embedded on a worksheet. My OS is Windows 10 Pro and my Excel version is Excel for Office 365 (16.0.11601.20174) 64-bit.

Best,
Nick
 
Upvote 0
Thanks again very much for the help and getting back so soon. Unfortunately, this still gives me the same error as above.

I have

Option Explicit

Private Sub ComboBox9_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Call SetComboBoxHook(ComboBox9)
End Sub

Private Sub ComboBox9_LostFocus()
Call RemoveComboBoxHook
End Sub

Private Sub ComboBox9_Change()
'change event not affected by the hook.
End Sub


for the code of ComboBox9 and the updated API in a generic Module2. The data in the list is not dynamic.

[TABLE="width: 81"]
<colgroup><col></colgroup><tbody>[TR]
[TD]
-----

[/TD]
[/TR]
[TR]


[/TR]
[TR]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
@ dagda13

Hi. You are correct. I could reproduce the issue you are experiencing on excel 2016 64bit.

I took a look and couldn't figure out the problem as the vba debugger doesn't give me the chance to locate the source of the error and the API declarations and code logic seems fine to me ... Interestingly, the code works well on all other excel versions !

I also, tried using a WH_MOUSE hook rather than the low level mouse hook WH_MOUSE_LL but it still errors out.

I'll take a different approach other than setting a mouse hook and I will post back if anything comes up.

Regards.
 
Upvote 0
@ dagda13

Ok, I have used the less invasive PeekMessage API function and discarded the use of the dangerous mouse hook approach.

I have tested the code on excel 2016 64bit and it no longer crashes.

Workbook Demo.


1- Code in a Standard Module :
Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type MSG
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 

    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If


Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WHEEL_DELTA = 120
Private Const MK_LBUTTON = &H1
Private Const PM_NOREMOVE = &H0
Private Const SM_CXVSCROLL = 2

Private bEnableMouseWheel As Boolean
Private oCurCombo As Object



Public Property Let EnableMouseWheel(ByVal Combobox As Object, ByVal Enable As Boolean)
    
    Dim tMsg As MSG, tRect As RECT
    Dim sBuffer As String * 256, lRet As Long
    Dim LowWord As Long, HighWord As Long, lParm As Long
     
    Application.EnableCancelKey = xlErrorHandler
    On Error GoTo UnSelectCombo
    
    bEnableMouseWheel = Enable
    
    If Not oCurCombo Is Nothing Then
        If oCurCombo Is Combobox Then
            GoTo XitLoop
        End If
    End If
    
    Set oCurCombo = Combobox
     
    If bEnableMouseWheel Then
        Debug.Print "MouseWheel Enabled for: " & oCurCombo.Name
        Do While bEnableMouseWheel
            Call WaitMessage
            If PeekMessage(tMsg, 0, 0, 0, PM_NOREMOVE) Then
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 And Win64 Then
                    Dim lPt As LongPtr, hwnd As LongPtr
                    CopyMemory lPt, tMsg.pt, LenB(tMsg.pt)
                    hwnd = WindowFromPoint(lPt)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
                    Dim hwnd As Long
                    hwnd = WindowFromPoint(tMsg.pt.X, tMsg.pt.Y)
                [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
                lRet = GetClassName(hwnd, sBuffer, 256)
                If InStr(Left(sBuffer, lRet), "F3 Server") Then
                    SetFocus hwnd
                    If tMsg.message = WM_MOUSEWHEEL Then
                        GetClientRect hwnd, tRect
                        LowWord = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                        If HiWord(CLng(tMsg.wParam)) = WHEEL_DELTA Then
                            HighWord = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                        ElseIf HiWord(CLng(tMsg.wParam)) = -WHEEL_DELTA Then
                            HighWord = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                        End If
                        lParm = LowWord + HighWord * &H10000
                        PostMessage hwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm
                        PostMessage hwnd, WM_LBUTTONUP, MK_LBUTTON, lParm
                    End If
                ElseIf Left(sBuffer, GetClassName(GetActiveWindow, sBuffer, 256)) = "wndclass_desked_gsk" Then
                    GoTo UnSelectCombo
                End If
            End If
            DoEvents
        Loop
    End If
    
    Exit Property
    
XitLoop:
    
    Debug.Print "MouseWheel Disabled for: " & oCurCombo.Name
    Set oCurCombo = Nothing
    Exit Property
    
UnSelectCombo:
    ActiveCell.Select

End Property


Private Function HiWord(ByVal dw As Long) As Integer
    CopyMemory HiWord, ByVal VarPtr(dw) + 2, 2
End Function



Code Usage:

2- The code below enables the mousewheel scroll for ComboBox1 and ComboBox2 (Can be applied to as many comboboxes as you like)


On the Worksheet Module:
Code: 
Option Explicit

Private Sub ComboBox1_GotFocus()
    EnableMouseWheel(ComboBox1) = True
End Sub

Private Sub ComboBox1_LostFocus()
    EnableMouseWheel(ComboBox1) = False
End Sub


Private Sub ComboBox2_GotFocus()
    EnableMouseWheel(ComboBox2) = True
End Sub

Private Sub ComboBox2_LostFocus()
    EnableMouseWheel(ComboBox2) = False
End Sub


Can you please confirm that this is now working .

Regards.
 
Last edited:
Upvote 0
Hi,

There are no more crashes or errors, but when I open the drop down of the ComboBox and try to scroll up or down with the mouse wheel, the drop down disappears (ie., flips back up). Odd!
 
Upvote 0
dagda13 said:
Hi,

There are no more crashes or errors, but when I open the drop down of the ComboBox and try to scroll up or down with the mouse wheel, the drop down disappears (ie., flips back up). Odd!
Click to expand...

Did you try the workbook download ? Does it happen on it or is is just on your specific workbook ?

I tested the code on 6 different machines with diff excel and windows editions and everything works perfect.

EDIT:
If you point with the mouse pointer right above the editbox section of the combobox and start mouse-wheel scrolling then the dropdon list disappears... This is normal.

However, if you point with the mouse over the dropdown section and start mouse scrolling then it should be fine.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
1
Views
387
Bib195
B
D
  • Solved
Long vs Longptr
Replies
7
Views
340
Micron
M
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
860
Jaafar Tribak
Jaafar Tribak
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
715
Jaafar Tribak
Jaafar Tribak
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
368
Minh Tuan VN
M

Forum statistics

Threads
1,224,798
Messages
6,181,038
Members
453,013
Latest member
Shubashish_Nandy

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top