Erreur de synthaxe

Le 24/07/2019 à 10:40

Bonjour

Je viens de passer d'Excel 2016 32 bits à Excel 2019 64 bits.

Depuis mon appli ne fonctionne plus quand je veux ouvrir certain tableau sur les ligne de code suivant apparait le message erreur de synthaxe (partie écrite en rouge).

.

Public Sub HookMouse(ByVal ControlToScroll As Object, ByVal SheetOrForm As OWNER, Optional ByVal FormName As String)

Dim hWnd As Long

Dim hWnd_App As Long

Dim hWnd_Desk As Long

Dim hWnd_Sheet As Long

Dim hWnd_UserForm As Long

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

De plus quand je lance un débogage j'ai l'erreur suivante qui apparait: "Erreur de compilation incompatibilité de Type"

sur les lignes suivantes :

Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT

CopyMemory (udtlParamStuct), lParam, LenB(udtlParamStuct)

GetHookStruct = udtlParamStuct

End Function

Merci d'avance si quelqu'un peut m'aider.

Bernard

Le 24/07/2019 à 10:45

Bonjour,

essaie de changer le Type Long par LongLong, mieux vaut LongPtr

Le 24/07/2019 à 11:15

Bonjour m3ellem1

Merci pour ta réponse.

J'ai essayé ceci :

Private Function GetHookStruct(ByVal lParam As LongLong) As MSLLHOOKSTRUCT

CopyMemory (udtlParamStuct), lParam, LenB(udtlParamStuct)

GetHookStruct = udtlParamStuct

End Function

Et aussi :

Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT

CopyMemory (udtlParamStuct), lParam, LenB(udtlParamStuct)

GetHookStruct = udtlParamStuct

End Function

Mais cela ne change rien.

Le 24/07/2019 à 11:21

j'ai vu que le plHooking n'est pas dimensionné

Ajoute aussi dans ton premier code:

plHooking As Long

Je pense aussi qur t'as plus de fonction sur le fichier. De préference mets nous un fichier test.

Le 24/07/2019 à 11:38

Merci pour ton aide et du temps que tu passe à m'aider, mais ce que code je l'avais récupérer sur internet et j'avoue que j'ai un peu de mal avec.

Je te renvoi l'ensemble avec les modifications que tu m'a proposé (en bleu), mais cela ne fonctionne pas.

Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long

Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) 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 Long

' sera associé à votre ComboBox/ListBox

Public CtrlHooked As Object

'

Private Function GetHookStruct(ByVal lParam As LongLong) As MSLLHOOKSTRUCT

CopyMemory (udtlParamStuct), lParam, LenB(udtlParamStuct)

GetHookStruct = udtlParamStuct

End Function

Private Function LowLevelMouseProc(ByVal nCode As LongLong, ByVal wParam As LongLong, ByVal lParam As LongLong) As Long

'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 Long

Dim hWnd_App As Long

Dim hWnd_Desk As Long

Dim hWnd_Sheet As Long

Dim hWnd_UserForm As Long

Dim plHooking As Long

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

Dis moi si c'est correct.

Le 24/07/2019 à 11:44

à tester

1-

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 PtrSafe 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 Long
' 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 Long
    '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 Long
    Dim hWnd_App As Long
    Dim hWnd_Desk As Long
    Dim hWnd_Sheet As Long
    Dim hWnd_UserForm As Long
    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

sinon

2-

Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 Long
Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As Long
Private Declare PtrSafe 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 Long
Private Declare PtrSafe Function CallNextHookEx Lib "User32" (ByVal hHook As LongPtr, ByVal nCode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As Long
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 Long
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
CopyMemory (udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function

Private Function LowLevelMouseProc(ByVal nCode As LongLong, ByVal wParam As LongLong, ByVal lParam As LongLong) As Long
'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 Long
Dim hWnd_App As Long
Dim hWnd_Desk As Long
Dim hWnd_Sheet As Long
Dim hWnd_UserForm As Long
Dim plHooking As Long
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
Le 24/07/2019 à 12:53

la version 2 fonctionne, mais quand je ferme l'userform et que je veux faire défiler le tableau avec la molette, l'erreur suivante apparait

"erreur de compilation incompatibilité de type"

Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT

CopyMemory (udtlParamStuct), lParam, LenB(udtlParamStuct)

GetHookStruct = udtlParamStuct

End Function

le terme en rouge est surligné, et excel se ferme.

Le 24/07/2019 à 14:44

Re,

à tester

Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 Long
Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As Long
Private Declare PtrSafe 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 Long
Private Declare PtrSafe Function CallNextHookEx Lib "User32" (ByVal hHook As LongPtr, ByVal nCode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As Long
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 Long
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
CopyMemory (udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function

Private Function LowLevelMouseProc(ByVal nCode As LongLong, ByVal wParam As LongLong, ByVal lParam As LongLong) As Long
'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 Long
Dim hWnd_App As Long
Dim hWnd_Desk As Long
Dim hWnd_Sheet As Long
Dim hWnd_UserForm As Long
Dim plHooking As Long
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
Le 24/07/2019 à 15:50

Re

Désolé cela ne fonctionne pas.

Je peux t'envoyer le fichier, mais il est lourd.

Quand tu l'ouvrira la barre le bandeau avec les outil n'apparait pas, il faut cliquer sur "afficher le menu principal ", et ensuite sur la petite icône en haut à gauche du menu principal.

Je te remercie beaucoup pour ton aide.

adresse du fichier : https://www.cjoint.com/c/IGynWARqxer

Le 24/07/2019 à 15:54

J'ai oublié de préciser

une fois l'appli ouverte il faut aller sur la feuille inscription course route cliquer sur la barre à gauche ouverture menu et ensuite ouvrir date course si tu fais défiler les courses avec la molette excel se plante.

encore merci.

Le 24/07/2019 à 15:59

Le problème est dans Modules ; modHookWheelMouse ; du code vba

Le 24/07/2019 à 16:10

Ok je vais voir ca ce soir

Le 24/07/2019 à 16:11

merci beaucoup,

Le 24/07/2019 à 21:32

Bonsoir,

bon dernier test 

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 PtrSafe 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
Le 25/07/2019 à 10:09

Bonjour

Formidable cela fonctionne très bien

A te relire

Le 25/07/2019 à 11:27

Re : m3ellem1

Désolé de revenir vers toi mais maintenant j'ai le même problème avec le code mot de passe "erreur de compilation incompatibilité de type"

'Module pour inputbox pour les mots de passe

Option Explicit

'Code écrit par Daniel Klann

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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr

Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _

(ByVal idHook As LongPtr, ByVal lpfn As Long, ByVal hmod As LongPtr, _

ByVal dwThreadId As LongPtr) As LongPtr

Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr

Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _

(ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, _

ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, _

ByVal lpClassName As String, _

ByVal nMaxCount As LongPtr) As LongPtr

Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr

Private Const EM_SETPASSWORDCHAR = &HCC

Private Const WH_CBT = 5

Private Const HCBT_ACTIVATE = 5

Private Const HC_ACTION = 0

Private hHook As Long

Public Function NewProc(ByVal lngCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Dim RetVal

Dim strClassName As String, lngBuffer As LongPtr

If lngCode < HC_ACTION Then

NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)

Exit Function

End If

strClassName = String$(256, " ")

lngBuffer = 255

If lngCode = HCBT_ACTIVATE Then

RetVal = GetClassName(wParam, strClassName, lngBuffer)

If Left$(strClassName, RetVal) = "#32770" Then

SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0

End If

End If

CallNextHookEx hHook, lngCode, wParam, lParam

End Function

Public Function InputBox(Prompt, Optional Title, Optional Default, Optional XPos, _

Optional YPos, Optional HelpFile, Optional Context) As String

Dim lngModHwnd As LongPtr, lngThreadID As LongPtr

lngThreadID = GetCurrentThreadId

lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

InputBox = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)

UnhookWindowsHookEx hHook

End Function

J'ai modifier les "Long" en "LongPtr", mais cela ne fonctionne pas.

Merci d'avance

Le 25/07/2019 à 12:07

Slt,

à tester

'Module pour inputbox pour les mots de passe
Option Explicit
'Code écrit par Daniel Klann
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 GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As Long, ByVal hmod As LongPtr, _
ByVal dwThreadId As LongPtr) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As LongPtr

Public Function NewProc(ByVal lngCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim RetVal
Dim strClassName As String, lngBuffer As LongPtr
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If
CallNextHookEx hHook, lngCode, wParam, lParam
End Function

Public Function InputBox(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As LongPtr, lngThreadID As LongPtr
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBox = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function
Le 25/07/2019 à 18:04

Re :

Merci le code que tu m'as envoyé semble très bien fonctionner,

Maintenant j'ai un autre PB qui est apparu depuis la dernière modif, je peux sauvegarder le fichier, mais je ne peut plus l'enregistrer.

(Je fait une sauvegarde sur un disque et un enregistrement sur un autre)

J'ai systématiquement une erreur 1004.

Ligne en rouge signalée comme erreur.

With ActiveWorkbook

chemin = Range("G15") 'répertoire

.SaveAs Filename:=chemin & nomfichier & extension

End With

MsgBox "Fichier enregistré !", vbInformation

Si tu as un peu de temps merci d'avance pour ton aide..

pour choisir les endroits pour enregistrer et sauvegarder il suffit de cliquer sur chaque image des petit classeurs sur la page de garde pour ouvrir l'endroit choisi.

ensuite ouvrir le menu principal et cliquer sur enregistrer et fermer.

je te joins l'adresse du fichier : https://cjoint.com/c/IGzpNlQ8BHr

Si tu peux, encore merci, j'ai essayé de modifier des termes, mais cela n'a rien changé.

Le 25/07/2019 à 20:36

Bonsoir

Ok c'est bon j'ai trouvé l'erreur, ne t'embête plus avec mes problèmes.

L'erreur venait du fait d'avoir mis ":" dans le début du nom du fichier dans la cellule A.

Encore merci et vraiment désolé pour le temps que tu as perdu.

A te relire.

Le 25/07/2019 à 20:39

LOL,

Je viens de lire ton message et je voulais allumer mon PC, donc c‘est bien que ca fonctionne

Bonne continuation !

Rechercher des sujets similaires à "erreur synthaxe"