Defilement Combobox et Listbox par Scroll de Souris

**Ghost0000** · 08/12/2017, 16h15

Bonjour,

J'ai trouvé du code permettant de faire faire défiler une combobox ou Listbox, le souci, c'est qu’apparemment il fonctionnait sous 32bits, et là, je le test, il me plante excel...
J'ai essayé de le rendre compatible sous 64bits (avec Ptrsafe et Longptr), je n'y arrive pas, pouvez-vous m'aidez ?

Voici le fichier ci-joint MouseWheelHookV2a_64bit.xlsm

Merci d'avance.

Cordialement.

GK

**unparia** · 08/12/2017, 18h14

Bonjour
Il est totalement hors de question que j'ouvre ton classeur. Et te rappelle que de tels procédés font l'objet d'une rubrique signalée "importante" dans la présente section du forum !
Quoi qu'il en soit : qu'il s'agisse de "ceci" ou qu'il s'agisse de "cela", le problème est que si ton application utilise des fonctions de l'Api de Windows, leur déclaration doit être faite en respectant le principe de la compilation conditionnelle.
Ce forum regorge de discussions et autres à ce propos. Sers-toi donc du moteur de recherche dont il est doté.

**Ghost0000** · 08/12/2017, 18h39

Hum...ok...

J'ai déjà cherché, sinon je posterai pas ici...

J'ai réussi a faire fonctionné le programme, mais le scroll ne fonctionne que dans le sens UP et non DOWN. Cela doit venir d'ici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 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

Sinon le code en totalité est le suivant : (si vous préférez avoir le code... plutôt que le fichier...)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
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 Any) 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
 
Type POINTAPI
  X As LongPtr
  Y As LongPtr
End Type
 
Type MSLLHOOKSTRUCT  'Will Hold the lParam struct Data
  pt As POINTAPI
  mouseData As LongPtr  ' Holds Forward\Bacward flag
  flags As LongPtr
  time As LongPtr
  dwExtraInfo As LongPtr
End Type
 
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
 
Dim hhkLowLevelMouse, 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

Cordialement.

GK

**Ghost0000** · 11/12/2017, 14h26

Quelqu'un pour m'aider a résoudre ce problème ?

Merci d'avance.

GK

**Ghost0000** · 11/12/2017, 17h03

En gros, ce truc la, me renvoi jamais de valeur négative :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

GetHookStruct(lParam).mouseData

Vous savez pourquoi ?

**Ghost0000** · 11/12/2017, 17h22

Ahh j'ai trouvé, en réalisé, il ne faut pas tous passé en LONGPTR.

Voici le code complet et fonctionnel sous x64bits :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Defilement Combobox et Listbox par Scroll de Souris [XL-2016]

Macros et VBA Excel

Discussions similaires

Partager

Partager