AW: Usetrfor 1&2 per Maustaste öffnen
07.03.2022 14:39:51
volti
Hallo Chris,
je nachdem, wofür Du das brauchst (z.B. nur die beiden Klicks zulassen) und wieviel Aufwand Du betreiben willst, könntest Du auch eine API-Lösung verwenden.
Bei der u.a. Lösung werden die beiden Mausklicks abgefangen und hier im Beispiel je eine MsgBox angezeigt. Die Originalmausaktivitäten werden geblockt.
Das Mausklicksabfangen muss jedoch z.B. nach Blattwechsel oder Mappenschließung, ggf. auch Mappenwechsel, abgeschaltet werden.
Kannst es ja mal ausprobieren.
Code:
' ############ In ein Modul #############
Option Explicit
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
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Type POINTAPI
x As Long
y As Long
End Type
Dim hHook As LongPtr
Private Const WH_MOUSE_LL = 14
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_RBUTTONDOWN = &H204
Sub MausAus()
UnhookWindowsHookEx hHook: hHook = 0
End Sub
Sub MausAn()
' Baut den Mousehook auf
If hHook <> 0 Then Exit Sub
hHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, _
Application.HinstancePtr, 0)
End Sub
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, _
lParam As LongPtr) As LongPtr
Dim PT As POINTAPI, oCurObj As Object
' Fängt Mausclicks ab
If nCode = 0 Then ' HC_ACTION
On Error Resume Next
Select Case wParam
Case WM_LBUTTONDOWN, WM_RBUTTONDOWN
GetCursorPos PT
Set oCurObj = ActiveWindow.RangeFromPoint(PT.x, PT.y)
If Not oCurObj Is Nothing Then
If TypeName(oCurObj) = "Range" Then
Call MausAus
' Ggf. Rangebereich einschränken über Intersect und oCurObj.address
If wParam = WM_LBUTTONDOWN Then
MsgBox "Call Userform1"
Else
MsgBox "Call Userform2"
End If
Call MausAn
Exit Function
End If
End If
End Select
End If
MouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
'########### In das Tabellenmodul #############
Private Sub Worksheet_Activate()
Call MausAn
End Sub
Private Sub Worksheet_Deactivate()
Call MausAus
End Sub
'########### In DieseArbeitsmappe #############
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call MausAus
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz