Excel 64 API et PtrSafe

**galopin01** · 21/03/2017, 21h14

Bonjour,
Pour dépanner quelqu'un j'ai essayé d'adapter une macro qui fonctionne bien en 32 bits pour la passer en 64 bits avec PtrSafe et des LongPtr...
Elle fonctionne toujours bien en 32 bits mais elle plante en 64. Or ce qui est demandé c'est qu'elle tourne surtout en 64 bits. Or je n'ai pas Excel 64 ...et je ne suis pas assez calé au niveau API pour résoudre ce pb.
But attendu : L'ensemble permet le scrolling pour le choix à l'intérieur d'un Combo1
Par suite le Userform comprend juste un combo (ComboBox1) et un bouton (cmdQuit)
Code du Userform :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub cmdQuit_Click()
   Unload Me
End Sub
Private Sub ComboBox1_Enter()
    Call HookMouse(Me.ComboBox1, eUSERFORM, Me.Name)
End Sub
Private Sub ComboBox1_Click()
    Me.cmdQuit.SetFocus
    UnHookMouse
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    UnHookMouse
End Sub

Code dans Module 1 :

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
103
104
105
106
107
108
109
110
111
112
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
   (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
   (ByVal hWnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
 
Private 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
Private Declare PtrSafe Function CallNextHookEx Lib "user32" _
   (ByVal hHook As LongPtr, ByVal nCode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _
   (ByVal hHook As LongPtr) As LongPtr
Public Enum OWNER
    eSHEET = 1
    eUSERFORM = 2
End Enum
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)
Private udtlParamStuct As MSLLHOOKSTRUCT
' permet de savoir si le hook est activé ou pas
Public plHooking As LongPtr
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    'en cas de mouvement très rapide,
    'évitons les crash en désactivant les erreurs
    On Error Resume Next
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
            ' déplace l'ascenseur en fonction de la molette
                ' l'info est stockée dans lParam
                If GetHookStruct(lParam).mouseData > 0 Then
                    .TopIndex = .TopIndex - 3
                Else
                    .TopIndex = .TopIndex + 3
                End If
            End With
        End If
        Exit Function
    End If
    LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    On Error GoTo 0
End Function
Public Sub HookMouse(ByVal ControlToScroll As Object, ByVal SheetOrForm As OWNER, Optional ByVal FormName As String)
    Dim hWnd As LongPtr
    Dim hWnd_App As LongPtr
    Dim hWnd_Desk As LongPtr
    Dim hWnd_Sheet As LongPtr
    Dim hWnd_UserForm As LongPtr
    Const VBA_EXCEL_CLASSNAME = "XLMAIN"
    Const VBA_EXCELSHEET_CLASSNAME = "EXCEL7"
    Const VBA_EXCELWORKBOOK_CLASSNAME = "XLDESK"
    Const VBA_USERFORM_CLASSNAME = "ThunderDFrame"
    ' active le hook s'il n'avait pas déjà été activé
    If plHooking < 1 Then
        ' retourne l'handle d'excel
        hWnd_App = FindWindow(VBA_EXCEL_CLASSNAME, vbNullString)
        Select Case SheetOrForm
        Case eSHEET
            'trouve son fils
            hWnd_Desk = FindWindowEx(hWnd_App, 0&, VBA_EXCELWORKBOOK_CLASSNAME, vbNullString)
            'trouve celui de la feuille
            hWnd_Sheet = FindWindowEx(hWnd_Desk, 0&, VBA_EXCELSHEET_CLASSNAME, vbNullString)
            hWnd = hWnd_Sheet
        Case eUSERFORM
            'trouve la UserForm
            hWnd_UserForm = FindWindowEx(hWnd_App, 0&, VBA_USERFORM_CLASSNAME, FormName)
            If hWnd_UserForm = 0 Then
                hWnd_UserForm = FindWindow(VBA_USERFORM_CLASSNAME, FormName)
            End If
            hWnd = hWnd_UserForm
        End Select
        Set CtrlHooked = ControlToScroll
        ' il n'y a pas de hInstance d'application, alors on utilise GetWindowLong pour obtenir l'hInstance
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(hWnd, GWL_HINSTANCE), 0)
        Debug.Print Timer, "Hook ON"
    End If
End Sub
Public Sub UnHookMouse()
    ' désactive le hook s'il existe
    If plHooking <> 0 Then
        UnhookWindowsHookEx plHooking
        plHooking = 0
        Set CtrlHooked = Nothing
        Debug.Print Timer, "Hook OFF"
    End If
End Sub

Un fichier démo est disponible sous ce lien
Merci
A+

**kiki29** · 21/03/2017, 21h41

Salut, plus d'info ici ? Développer avec Office 64 bits
Un exemple d'adaptation Liste des fichiers d'un dossier réalisé par Clément Marcotte.

**galopin01** · 21/03/2017, 22h00

Bonsoir,

Je connais ce lien et je l'ai déjà donné à l'intéressé, mais comme je l'ai dit je ne suis pas assez calé pour faire la différence entre un pointeur qui doit passer en LongPtr d'une variable qui elle doit rester en Long. De plus il y a des LongLong. Toussa est un peu complexe.
Comme en plus il faut faire un jeu de piste pour voir commenté sont déclaré les paramètres dans les Api pour les ajuster au même type dans les Sub ou les Function ça devient vite un casse tête. Et comme je n'ai pas un 64 bit. Je ne peux même pas tenter le débogage pour situer l'erreur.

Dans le même type de situation avec un Textbox par tâtonnement je suis arrivé au résultat voulu, mais là je suis un peu dépassé...

A+

**kiki29** · 21/03/2017, 22h15

Salut, de même je n'ai pas de version 64 bits d'Office installée

D'autant plus que même Microsoft déconseille l'installation d'une version 64 bits d'Office.

Office 32 bits est recommandé pour la plupart des utilisateurs
Nous recommandons la version 32 bits d’Office pour la plupart des utilisateurs, car elle offre une plus grande compatibilité avec la plupart des autres applications, en particulier les compléments tiers. C’est la raison pour laquelle la version 32 bits d’Office 2013 est installée par défaut, même sur les systèmes d’exploitation Windows 64 bits. Sur ces systèmes, le client Office 32 bits est pris en charge en tant qu’installation Windows-32-on-Windows-64 (WOW64). WOW64 est l’émulateur x86 qui permet l’exécution de façon transparente des applications Windows 32 bits sur les systèmes Windows 64 bits. Cela permet aux utilisateurs de continuer à utiliser les contrôles ActiveX et les compléments COM Microsoft avec la version 32 bits d’Office.

Invité · 21/03/2017, 23h01

Code :

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

1
2
3
4
5
6
#if win7 then
     PrivateDeclare PtrSafe Function FindWindow Lib"user32"Alias"FindWindowA(ByVal lpClassName AsString, ByVal lpWindowName AsString)As Long#else
#else
Private Declare  Function FindWindow Lib "user32" Alias "FindWindowA (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#end if

**galopin01** · 22/03/2017, 06h54

bonjour,

Envoyé par kiki29

Microsoft déconseille l'installation d'une version 64 bits d'Office.

Je sais, je sais... Mais c'est comme ça !
La macro ne tournera que sur un 64 bit et W7

dysorthographie :

Code :

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

1
2
#if win7 then
     PrivateDeclare PtrSafe Function FindWindow Lib"user32"Alias"FindWindowA(ByVal lpClassName AsString, ByVal lpWindowName AsString)As Long

J'ai plus qu'un doute !

J'ai commencé le jeu de piste pour traquer les pointeurs et paramètres qui doivent ou ne doivent pas être typées LongPtr et pour le moment j'en suis là :

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
103
104
105
106
107
108
109
110
111
112
113
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
   (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
   (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
 
Private 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
Private Declare PtrSafe Function CallNextHookEx Lib "user32" _
   (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr 
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _
   (ByVal hHook As LongPtr) As Long
 
Public Enum OWNER
    eSHEET = 1
    eUSERFORM = 2
End Enum
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)
Private udtlParamStuct As MSLLHOOKSTRUCT
' permet de savoir si le hook est activé ou pas
Public plHooking As LongPtr
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    'en cas de mouvement très rapide,
    'évitons les crash en désactivant les erreurs
    On Error Resume Next
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
            ' déplace l'ascenseur en fonction de la molette
                ' l'info est stockée dans lParam
                If GetHookStruct(lParam).mouseData > 0 Then
                    .TopIndex = .TopIndex - 3
                Else
                    .TopIndex = .TopIndex + 3
                End If
            End With
        End If
        Exit Function
    End If
    LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    On Error GoTo 0
End Function
Public Sub HookMouse(ByVal ControlToScroll As Object, ByVal SheetOrForm As OWNER, Optional ByVal FormName As String)
    Dim hWnd As LongPtr
    Dim hWnd_App As LongPtr
    Dim hWnd_Desk As LongPtr
    Dim hWnd_Sheet As LongPtr
    Dim hWnd_UserForm As LongPtr
    Const VBA_EXCEL_CLASSNAME = "XLMAIN"
    Const VBA_EXCELSHEET_CLASSNAME = "EXCEL7"
    Const VBA_EXCELWORKBOOK_CLASSNAME = "XLDESK"
    Const VBA_USERFORM_CLASSNAME = "ThunderDFrame"
    ' active le hook s'il n'avait pas déjà été activé
    If plHooking < 1 Then
        ' retourne l'handle d'excel
        hWnd_App = FindWindow(VBA_EXCEL_CLASSNAME, vbNullString)
        Select Case SheetOrForm
        Case eSHEET
            'trouve son fils
            hWnd_Desk = FindWindowEx(hWnd_App, 0&, VBA_EXCELWORKBOOK_CLASSNAME, vbNullString)
            'trouve celui de la feuille
            hWnd_Sheet = FindWindowEx(hWnd_Desk, 0&, VBA_EXCELSHEET_CLASSNAME, vbNullString)
            hWnd = hWnd_Sheet
        Case eUSERFORM
            'trouve la UserForm
            hWnd_UserForm = FindWindowEx(hWnd_App, 0&, VBA_USERFORM_CLASSNAME, FormName)
            If hWnd_UserForm = 0 Then
                hWnd_UserForm = FindWindow(VBA_USERFORM_CLASSNAME, FormName)
            End If
            hWnd = hWnd_UserForm
        End Select
        Set CtrlHooked = ControlToScroll
        ' il n'y a pas de hInstance d'application, alors on utilise GetWindowLong pour obtenir l'hInstance
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(hWnd, GWL_HINSTANCE), 0)
        Debug.Print Timer, "Hook ON"
    End If
End Sub
Public Sub UnHookMouse()
    ' désactive le hook s'il existe
    If plHooking <> 0 Then
        UnhookWindowsHookEx plHooking
        plHooking = 0
        Set CtrlHooked = Nothing
        Debug.Print Timer, "Hook OFF"
    End If
End Sub

Bonne journée.

Invité · 22/03/2017, 07h06

Bonjour,
Seul la déclaration change en PtrSafe, tu prend la déclaration 32 bits et tu rajoute PtrSafe!

32 bits long!

**galopin01** · 22/03/2017, 08h47

Je prends bonne note de cette affirmation (il me semble bien que j'ai déjà vu ça quelque part...) bien que la plupart des articles sur le net semblent dire le contraire !
De toute façon je ne peux pas tester.

et ça ne me dit pas comment traiter la Sub CopyMemory
Ni les variables qui suivent dans le Private Type MSLLHOOKSTRUCT

Bon enfin, on va pas en faire un fromage...
L'idée de base était de fournir une routine clef en main pour ceux qui ont besoin de parcourir aisément des combos énormes.
Ça me semblait une idée intéressante déjà bien documenté sur Google (en 32 bits)
Yapa de raison que ça ne vienne pas sur le 64 bits (J'en vois passer de plus en plus...)
De toute façon je ne peux pas finaliser tout seul. On laissera donc ça en suspens pour le moment.

Merci.

A+

Invité · 22/03/2017, 09h23

https://www.developpez.net/forums/d1...v/#post8305353

Code :

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

1
2
3
PrivateFunction GetHookStruct(ByVal lParam As Long)As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct EndFunction

**galopin01** · 22/03/2017, 11h10

Oui, oui ça j'avais compris : Si on supprime les LongPtr dans les API on les remplace aussi par des "long" dans les paramètres et les variables...

Il faut que j'attende le retour des essais.

A+

**Arkham46** · 25/03/2017, 18h41

Bonjour,

À vous lire ça semble facile.
S'il suffisait d'ajouter PtrSafe sans réfléchir je n'aurais pas écrit un article sur le sujet.
Et puis dans ce cas, quel serait l'intérêt de cette instruction ?
Il faut bien "sécuriser les pointeurs" avant d'ajouter "PtrSafe" (d'où le nom de cette instruction) sinon l'application risque de planter violemment.
Parfois ça fonctionne sans tout bien securiser (tant qu'on ne tombe pas sur des valeurs de pointeurs trop importantes), et un jour ça plante sans prévenir.

**galopin01** · 25/03/2017, 19h07

Merci pour cette confirmation.
N'ayant pas de 64 bits à la maison je n'avais parcouru ton article qu'en diagonale...
Bon de toute façon j'ai donné toutes les références nécessaires à l'heureux initiateur de ce méchant casse tête.
Donc je clos provisoirement le sujet.
Bon Dimanche.

Excel 64 API et PtrSafe

Macros et VBA Excel

Discussions similaires

Partager

Partager