AW: Mausgesten in Excel ?
20.07.2022 23:58:10
volti
Hallo Dieter,
mit u.a. Code werden die Mausgesten nur für den definierten Bereich (als Konstante definiert) aktiv.
Gleichzeitig habe ich nur das gewünschte Tabellenblatt für die Mausgesten aktiviert. Damit sind andere Tabellenblätter vom Mousehooking ausgeschlossen.
Probiere es halt mal aus.
Code:
' In das Codemodul
Option Explicit
Option Private Module
Private Declare PtrSafe Function SetWindowsHookExA Lib "user32" ( _
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 Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim hHook As LongPtr
Const WH_MOUSE_LL As Long = 14
Const csActiveRange As String = "A1:F10"
Const csActiveRow As String = "A#:F#"
Private lLastRow As Long
Public Sub StartMaus()
If hHook = 0 Then ' Baut den Mousehook auf
hHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, _
Application.HinstancePtr, 0)
End If
End Sub
Public Sub StopMaus()
UnhookWindowsHookEx hHook: hHook = 0 ' Beendet den Mousehook
End Sub
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, _
lParam As LongPtr) As LongPtr
Dim udtPoint As POINTAPI
Dim objUnknown As Object
On Error GoTo err_exit
If nCode = &H0 And wParam = &H200 Then '&H0=HC_ACTION, &H200=WM_MOUSEMOVE
' Aktionsabarbeitung nur bei Mausbewegungen
Call GetCursorPos(udtPoint) ' Ermittle Mausposition
Set objUnknown = ActiveWindow.RangeFromPoint(udtPoint.X, udtPoint.Y)
If Not objUnknown Is Nothing Then
If TypeOf objUnknown Is Range Then
If Intersect(Range(csActiveRange), objUnknown) Is Nothing Then
If lLastRow <> 0 Then
Range(csActiveRange).Interior.Pattern = xlPatternNone
lLastRow = 0
End If
Else
If lLastRow <> 0 Then
If lLastRow <> objUnknown.Row Then
Range(Replace(csActiveRow, "#", lLastRow)).Interior.Pattern = xlPatternNone
End If
End If
lLastRow = objUnknown.Row ' Letzte Zeile merken
Range(Replace(csActiveRow, "#", lLastRow)).Interior.Color = RGB(255, 255, 153)
End If
End If
End If
Exit Function
End If
err_exit:
MouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam) ' Mousemessages an Excel weitergeben
End Function
' In das DieseArbeitsmappe-Modul
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "Tabelle1" Then Call StartMaus ' Mausgesten starten
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Sh.Name = "Tabelle1" Then Call StopMaus ' Mausgesten starten
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz