|
Hallo Siggi,
ich denke es läuft jetzt bei Dir?
Die hier getätigten Aussagen bezgl. der Declares in Deiner Ursprungsversion ist, wie ich ja auch schon anmerkte, richtig. Da stimmte nichts.
Da hilft es m.E. aber wenig, übrigens namenlos und ohne Kopf und Fuß, einem mehr oder weniger unbedarften API-Anfänger für eine Declare eine C-Notation zu zeigen.
Ich nutze dafür meinen API-Viewer oder schaue mir das für VBA im Internet an.
Aber nun gut.
Die IDHook ist auf jeden Fall vom Typ Long, und wenn es damit nicht läuft, muss es ein anderer Fehler sein.
Die Aussage zur Declare WindowFromPoint bzgl. der Longlong-Variablen ist nicht richtig. Das läuft sehr wohl damit.
Nachdem ich das schon öfter gelesen habe, u.a. auch anstatt Longlong z.B. Currency oder LongPtr einzusetzen (ist auch bei 32Bit einsetzbar) oder gleich mit X,Y zu arbeiten, habe ich das alles ausprobiert und muss folgendes dazu sagen:
Grundsätzlich liefern alle Varianten Handle (aber nicht immer die gleichen) zurück und es funktioniert teilweise in einigen Anwendungen.
Aber mindestens in einer meiner Anwendungen läuft nur die Longlong-Variante dauerhaft, die anderen Varianten führen bei mir irgendwann zum Absturz.
Prüfung auf Win64 hin oder her, ich nutze jetzt wieder die getrennte Variante.
Ich habe jetzt wenig Lust, umfangreiche Codes ohne Datei auf Unzulänglichkeiten zu prüfen.
Daher, wenn Du magst, kannst Du Dir gerne auch eine meiner Varianten zum Thema Mousewheeling anschauen....(Sollte auf allen Versionen laufen, ist aber nur für 64 Bit gesichert geprüft)
Bin auch gern bereit, für diese Version weitere Hilfe zu leisten.
Wie Hajo schon immer schrieb: Das ist nur meine bescheidene Meinung zu dem Thema. :-)
PS: Aufrufbeispiel aus einer Userform:
Code:
01
02
03
04
05
06
07
08
09
10
11
12 |
|
Private Sub CB_Libs_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) _
Call HookMouse(CB_Libs)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call UnhookMouse
End Sub
Private Sub UserForm_Deactivate()
Call UnhookMouse
End Sub
|
In ein Modul:
Code:
001
002
003
004
005
006
007
008
009
010
011
012
013
014
015
016
017
018
019
020
021
022
023
024
025
026
027
028
029
030
031
032
033
034
035
036
037
038
039
040
041
042
043
044
045
046
047
048
049
050
051
052
053
054
055
056
057
058
059
060
061
062
063
064
065
066
067
068
069
070
071
072
073
074
075
076
077
078
079
080
081
082
083
084
085
086
087
088
089
090
091
092
093
094
095
096
097
098
099
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209 |
|
Option Explicit
#If Win64 Then
Private Type POINTAPI
XY As LongLong
End Type
#Else
Private Type POINTAPI
X As Long
Y As Long
End Type
#End If
#If VBA7 Then
Private Declare PtrSafe Function SetWindowsHookExA Lib "user32.dll" ( _
ByVal idHook As Long, ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr, ByVal nCode As Long, _
ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr) As Long
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongA Lib "user32.dll" _
Alias "GetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal point As LongLong) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongA Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetKeyState Lib "user32.dll" ( _
ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Type MOUSEHOOKSTRUCT
PT As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
Private ghHook As LongPtr
Private ghWndCtrl As LongPtr
#Else
Private Declare Function SetWindowsHookExA Lib "user32.dll" ( _
ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32.dll" ( _
ByVal hHook As Long, ByVal nCode As Long, _
ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" ( _
ByVal hHook As Long) As Long
Private Declare Function GetWindowLongA Lib "user32" ( _
ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetKeyState Lib "user32.dll" ( _
ByVal nVirtKey As Long) As Integer
Private Declare Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Type MOUSEHOOKSTRUCT
PT As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private ghHook As Long
Private ghWndCtrl As Long
#End If
Private Const csStep As Integer = 1 ' <<<< Scrollschrittweite setzen >>>>
Private Const WH_MOUSE_LL As Long = 14&
Private Const HC_ACTION As Long = 0&
Private Const GWL_HINSTANCE As Long = -6&
Private Const WM_KEYDOWN As Long = &H100
Private glPage As Long
Private goControl As MSForms.control
Public Sub HookMouse(ByRef oControl As MSForms.control, Optional ByVal lPage As Long)
' Hook-Prozedur zum Abfangen der Mausaktivitäten setzen
' Wird nur bei Mausbewegungen im Control angesprungen
Dim PT As POINTAPI
GetCursorPos PT ' Cursorposition holen
#If VBA7 Then
Dim hWndCur As LongPtr
#Else
Dim hWndCur As Long
#End If
#If Win64 Then
hWndCur = WindowFromPoint(PT.XY) ' Handle des Controls unter Maus holen
#Else
hWndCur = WindowFromPoint(PT.X, PT.Y) ' Handle des Controls unter Maus holen
#End If
glPage = lPage
If ghWndCtrl <> hWndCur Then ' Wenn neues Control oder keins mehr
Call UnhookMouse ' Maus unhooken
Set goControl = oControl ' Control global machen
ghWndCtrl = hWndCur ' Gleichheit merken
If ghHook = 0 Then ' Maushook setzen, wenn nicht schon aktiv
ghHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, _
GetWindowLongA(ghWndCtrl, GWL_HINSTANCE), 0&)
End If
End If
End Sub
Public Sub UnhookMouse()
If ghHook <> 0 Then ' Wenn Maus bereits gehokt
UnhookWindowsHookEx ghHook ' Maus unhooken
Set goControl = Nothing ' Objekt zurücksetzen
ghHook = 0: ghWndCtrl = 0 ' Parameter leeren
End If
End Sub
#If VBA7 Then
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) _
As LongPtr
Dim hWndCur As LongPtr
#Else
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) _
As Long
Dim hWndCur As Long
#End If
Dim oControl As MSForms.control, bScrollDown As Boolean
Set oControl = goControl
On Error GoTo Fehler
If nCode = HC_ACTION Then
#If Win64 Then
hWndCur = WindowFromPoint(lParam.PT.XY)
#Else
hWndCur = WindowFromPoint(lParam.PT.X, lParam.PT.Y)
#End If
If hWndCur = ghWndCtrl Then
If wParam = &H20A Then ' WM_MOUSEWHEEL-Message
bScrollDown = lParam.hwnd = &H780000
If TypeOf oControl Is MSForms.ListBox Or TypeOf oControl Is MSForms.ComboBox Then
With oControl
If GetKeyState(vbKeyControl) >= 0 Then
If bScrollDown Then
If .TopIndex > 0 Then .TopIndex = IIf(.TopIndex > csStep, .TopIndex - csStep, _
0)
Else
.TopIndex = .TopIndex + csStep
End If
Else
If TypeOf oControl Is MSForms.ListBox Then
If bScrollDown Then
PostMessageA ghWndCtrl, WM_KEYDOWN, vbKeyLeft, 0
Else
PostMessageA ghWndCtrl, WM_KEYDOWN, vbKeyRight, 0
End If
End If
End If
End With
Else
If TypeOf oControl Is MSForms.MultiPage Then Set oControl = oControl.Pages(glPage)
With oControl
If GetKeyState(vbKeyControl) >= 0 Then
If bScrollDown Then
.ScrollTop = IIf(.ScrollTop > 0, .ScrollTop - 30, 0)
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If bScrollDown Then
.ScrollLeft = IIf(.ScrollLeft > 0, .ScrollLeft - 30, 0)
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
End If
Exit Function
End If
Else
Call UnhookMouse
End If
End If
MouseProc = CallNextHookEx(ghHook, nCode, wParam, ByVal lParam)
Exit Function
Fehler:
Call UnhookMouse
End Function
|
_________
viele Grüße
Karl-Heinz
|