1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
| Option Explicit
'-----Allows use of MouseWheel on designated ListBox/ComboBox on a form or, sheet if modified.--------
#If Win64 Then ' 64bits version
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As LongPtr, ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Declare PtrSafe Function GetLastError Lib "kernel32" () As LongPtr ' Used this one to crack the problem.
#Else ' 32bits version
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function GetForegroundWindow Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length 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 GetLastError Lib "kernel32" () As Long ' Used this one to crack the problem.
#End If
'Problème résolu aprés modification de longptr en Long. :)
Type POINTAPI
X As Long
Y As Long
End Type
Type MSLLHOOKSTRUCT 'Will Hold the lParam struct Data
pt As POINTAPI
mouseData As Long ' Holds Forward\Bacward flag
flags As Long
time As Long
dwExtraInfo As Long
End Type
Public Const HC_ACTION = 0
Public Const WH_MOUSE_LL = 14
Public Const WM_MOUSEWHEEL = &H20A
Dim hhkLowLevelMouse As LongPtr, lngInitialColor As LongPtr
Dim udtlParamStuct As MSLLHOOKSTRUCT
Public Const GWL_HINSTANCE = (-6)
Public intTopIndex As Integer
Public ObjUSF As UserForm, ObjList As Object
Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
' VarPtr returns address; LenB returns size in bytes.
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
Function LowLevelMouseProc(ByVal nCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
'Avoid XL crashing if RunTime error occurs due to Mouse fast movement
On Error Resume Next
' \\ Unhook & get out in case the application is deactivated
If GetForegroundWindow <> FindWindow("ThunderDFrame", ObjUSF.Caption) Then
' Sheets("Sheet1").ComboBox1.TopLeftCell.Select
UnHook_Mouse
Exit Function
End If
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
'\\ Don't process Default WM_MOUSEWHEEL Window message
LowLevelMouseProc = True
'\\ Change Sheet&\DropDown names as required
With ObjList
'\\ if rolling forward increase Top index by 1 to cause an Up Scroll
If GetHookStruct(lParam).mouseData > 0 Then
.TopIndex = intTopIndex - 1
'\\ Store new TopIndex value
intTopIndex = .TopIndex
Else '\\ if rolling backward decrease Top index by 1 to cause _
'\\a Down Scroll
.TopIndex = intTopIndex + 1
'\\ Store new TopIndex value
intTopIndex = .TopIndex
End If
End With
End If
Exit Function
End If
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
Sub Hook_Mouse()
' Statement to maintain the handle of the hook if clicking outside of the control.
' There isn't a Hinstance for Application, so used GetWindowLong to get handle.
If hhkLowLevelMouse < 1 Then hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(FindWindow("ThunderDFrame", ObjUSF.Caption), GWL_HINSTANCE), 0)
End Sub
Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then
UnhookWindowsHookEx hhkLowLevelMouse
hhkLowLevelMouse = 0
End If
'MsgBox (GetLastError())
End Sub |
utilisation de la roulette dans une listbox
Répondre avec citation
Partager