'patricktoulon
#If VBA7 Then
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 UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
#Else
Private 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
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
#End If
' Constantes pour les événements souris
Const WM_MOUSEMOVE As Long = &H200
Const WM_LBUTTONDOWN As Long = &H201
Const WM_LBUTTONUP As Long = &H202
Dim MouseIsDown As Boolean ' Variable pour suivre l'état du bouton de la souris
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 LongPtr
End Type
Dim hHook As LongPtr
Dim oldleft As Long
' Fonction Hook pour la souris
Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
'patricktoulon
Dim mouseInfo As MSLLHOOKSTRUCT
If nCode = 0 Then
' Copie des données de la souris
CopyMemory mouseInfo, ByVal lParam, LenB(mouseInfo)
' Gestion des événements
Select Case wParam
Case WM_LBUTTONDOWN
MouseIsDown = True
Case WM_MOUSEMOVE
If MouseIsDown Then
On Error Resume Next
If oldleft = 0 Then oldleft = Application.Left
If Application.Left <> oldleft Then oldleft = Application.Left: DragingWindow
On Error GoTo 0
End If
Case WM_LBUTTONUP
If MouseIsDown Then
MouseIsDown = False
oldleft = 0
If Application.Left <> oldleft Then StopDragingWindow
End If
End Select
End If
' Passer au prochain Hook
MouseProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function
' Démarre le Hook
Sub StartMouseHook()
Const WH_MOUSE_LL As Long = 14
hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, 0, 0)
If hHook = 0 Then MsgBox "Impossible d'installer le Hook", vbCritical
End Sub
' Arrête le Hook
Sub StopMouseHook()
On Error Resume Next
If hHook <> 0 Then
UnhookWindowsHookEx hHook
hHook = 0
MsgBox "Hook souris arrêté", vbInformation
End If
End Sub
'les faux events
Public Sub DragingWindow()
On Error Resume Next
[a1] = "déplacement"
End Sub
Public Sub StopDragingWindow()
On Error Resume Next
[a1] = "arrêt du déplacement"
End Sub
