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
103
104
105
106
107
| Public Class LaureatHook
'-----Allows use of MouseWheel on designated ListBox/ComboBox on a form or, sheet if modified.--------
'Option Explicit
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, ByVal lParam As Long) 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.
Public Structure POINTAPI
Public X As Long
Public Y As Long
End Structure
' Déclaration de la structure appelée MSLLHOOKSTRUCT
Public Structure MSLLHOOKSTRUCT 'Will Hold the lParam struct Data
Public pt As POINTAPI
Public mouseData As Long ' Holds Forward\Bacward flag
Public flags As Long
Public time As Long
Public dwExtraInfo As Long
End Structure
Public Const HC_ACTION = 0
Public Const WH_MOUSE_LL = 14
Public Const WM_MOUSEWHEEL = &H20A
Public hhkLowLevelMouse, lngInitialColor As Long
Public udtlParamStuct As MSLLHOOKSTRUCT
Public LaFenetre As Long
Public Const GWL_HINSTANCE = (-6)
Public intTopIndex As Integer
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
' VarPtr returns address; LenB returns size in bytes.
CopyMemory(udtlParamStuct, lParam, udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As String
'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 <> LaFenetre Then
UnHook_Mouse(LaFenetre)
Return ""
End If
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
'\\ Don't process Default WM_MOUSEWHEEL Window message
LowLevelMouseProc = True
If GetHookStruct(lParam).mouseData > 0 Then
'Up Scroll
Return "-1"
Else '\\ if rolling backward decrease Top index by 1 to cause _
'\\Down Scroll
Return "1"
End If
End If
Return ""
End If
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, lParam)
End Function
Sub Hook_Mouse(ByVal wFenetre As Long)
' 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.
LaFenetre = wFenetre
If hhkLowLevelMouse < 1 Then hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, _
wFenetre, GWL_HINSTANCE)
End Sub
Sub UnHook_Mouse(ByVal wFenetre As Long)
If hhkLowLevelMouse <> 0 Then
UnhookWindowsHookEx(hhkLowLevelMouse)
hhkLowLevelMouse = 0
End If
End Sub
Private Sub CopyMemory(ByVal udtlParamStuct As MSLLHOOKSTRUCT, ByVal lParam As Long, ByVal udtlParamStuct1 As MSLLHOOKSTRUCT)
Throw New NotImplementedException
End Sub
End Class |
