IF Then Mausabfrage

Aton · 2020-09-30T20:50:37+00:00

Hallo Ich würde mich freuen, wenn jemand meine Mausabfrage zum fuktionieren brächte. Gruß Aton Dim UdtPoints As POINTAPI Dim LaufZeit As Long Dim X As Long, Y As Long Option Explicit Private Declare Function GetCursorPos Lib "user32" ( _ lpPoint As POINTAPI) As Long Private Type POINTAPI X As Long Y As Long End Type Sub CursorPosition_Statusleiste() For LaufZeit = 1 To 400 GetCursorPos UdtPoints ' Application.StatusBar = "Xpos " & CStr(UdtPoints.x) & " XPos " & CStr(UdtPoints.y) ' X _ _ Pos und Y Pos in der Statusleiste anzeigen Range("B1") = CStr(UdtPoints.X) ' X Pos Range("C1") = CStr(UdtPoints.Y) ' Y Pos ' If "Maustaste Links gedrückt" Then Application.Run "LinienZeichnen", X, Y ' Mein Makro _ _ das die Linie zeichnet ' If "Maustaste Rechts gedrückt" Then Exit For ' Zeitschleife verlassen Next LaufZeit Application.Run "LinienZeichnen", X, Y ' Der Aufruf der mein Makro startet, das die Linie _ zeichnet. ' 1. Makrostart wird Start Punkt gesetzt. ' 2. Makrostart wir die Line vom Startpunkt zu diesem Punkt gezeichnet. ' 3. Und dann als neuer Startpunkt gemerkt. ' 4. So kann ich eine Linienfolge von Punkt 1 zu 2 zu 3 usw. zeichnen. Punkt = Pixel auf _ Bildschirm. ' 5. Muss aber für jeden Punkt das Makro neu starten. ' 6. Mit einer Maustastenabfrage müsste ich nicht immer 2 Sekunden warten um einen Punkt _ festzulegen ' und könnte eine Dauerschleife mit der Rechten Maustaste verlassen, wenn ich den _ letzten Punkt eingegeben habe. End Sub

Hallo Aton,
da das Thema wohl noch offen ist und sonst niemand antwortet, hier noch ein Versuch:
Wenn es noch so ist wie früher, laufen die Mausaktivitäten über einen Port ein und werden vom Maustreiber entsprechend verarbeitet.
Über Mausadressen im Arbeitsspeicher weiß ich nichts. Ich lasse die Frage deshalb mal offen.
Die von mir anfangs vorgeschlagene Abfrage der Maustasten mittels GetAsyncKeyState funktioniert schon, allerdings werden weiterhin die Mausaktivitäten an Excel gesendet, so dass das dann etwas unsauber funktioniert.
Z.B. müsstest Du auch die Rechtsclick-Routine bei den Tabellenevents abschalten, da die ja Dein Vorhaben zunichte machen.
Hier mal eine neue Idee, die allerdings etwas umfangreicher ist und die Mausaktivitäten in einer eigenen Prozedur abfängt.
Vielleicht sagt sie Dir ja mehr zu. Probiere es einfach mal aus.
Diesen Code hier ein das Tabellenmodul:

Code:
[Cc] 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Mausabfrage
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
 If gbMausaktion Then Cancel = True
End Sub

Diesen Code hier ein normales Modul:

Code:
[Cc][+][-] 
Option Explicit

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
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, ByVal ncode As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As LongPtr) As Long
Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
        Alias "GetWindowLongA" ( _
        ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Declare PtrSafe Function GetAsyncKeyState Lib "user32" ( _
        ByVal vKey As Long) As Integer

Type POINTAPI
  x As Long
  y As Long
End Type

Type MOUSEHOOKSTRUCT
  PT           As POINTAPI
  hWnd         As LongPtr
  wHitTestCode As Long
  dwExtraInfo  As LongPtr
End Type

Public gbMausaktion As Boolean
Const WM_LBUTTONDOWN = &H201
Const WM_RBUTTONDOWN = &H204
Const WM_LBUTTONUP = &H202
Const WM_RBUTTONUP = &H205

Const HC_ACTION = &H0
Const WH_MOUSE = 7
Const GWL_HINSTANCE = (-6)

Dim hHook As LongPtr

Sub Mausabfrage()
 
 gbMausaktion = True
 hHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, _
         GetWindowLongPtr(Application.hWnd, GWL_HINSTANCE), _
         GetCurrentThreadId)
 
 Do
  DoEvents
  If GetAsyncKeyState(27) <> 0 Then Exit Do 'Exit
 Loop
 
 gbMausaktion = False
 UnhookWindowsHookEx hHook                  'UnHook ist wichtig
 MsgBox "Aktion beendet!", vbInformation, "Maus..."
End Sub


Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, _
        lParam As MOUSEHOOKSTRUCT) As LongPtr
 On Error GoTo Fehler
 
 Select Case ncode
 Case HC_ACTION
    If lParam.hWnd > 0 Then
       Range("B1").Value = lParam.PT.x  'Mausposition X in Zelle ablegen
       Range("C1").Value = lParam.PT.y  'Mausposition Y in Zelle ablegen
          
       Select Case wParam
       Case WM_LBUTTONDOWN: Cells(1, 7) = Cells(1, 2)
       Case WM_RBUTTONDOWN: Cells(1, 8) = Cells(1, 3)
       Case WM_LBUTTONUP, WM_RBUTTONUP
       End Select
       
    End If
 Case Else
    MouseProc = CallNextHookEx(hHook, ncode, wParam, lParam)
 End Select

Fehler:
End Function

____________________
viele Grüße aus Freigericht
Karl-Heinz

Hallo Aton,
vielen Dank für die positive Rückmeldung.
Mit "Tabellenmodul" meinte ich das Klassenmodul der Tabelle, in dem die Felder gefüllt werden.
Dort hatte ich mit dem ersten Codeteil den Rechtsklick abgeschaltet und den Start der Sub über Doppelklick auf dem Tabellenblatt generiert.
Vielleicht brauchst Du das ja auch nicht, ich kenne (mangels bereitgestellter Datei) ja nicht Deine genaue Vorgehensweise und Anforderung...
Kann ich auch Rechte Maustaste zum Abbruch nehmen ?
Ja, na klar z.B. so:

Code:
[Cc][+][-] 


	
	
	
	


Option Explicit

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
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, ByVal ncode As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As LongPtr) As Long
Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
        Alias "GetWindowLongA" ( _
        ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Declare PtrSafe Function GetAsyncKeyState Lib "user32" ( _
        ByVal vKey As Long) As Integer

Type POINTAPI
  x As Long
  y As Long
End Type

Type MOUSEHOOKSTRUCT
  PT           As POINTAPI
  hWnd         As LongPtr
  wHitTestCode As Long
  dwExtraInfo  As LongPtr
End Type

Public gbMausaktion As Boolean
Const WM_LBUTTONDOWN = &H201
Const WM_RBUTTONDOWN = &H204
Const WM_LBUTTONUP = &H202
Const WM_RBUTTONUP = &H205

Const HC_ACTION = &H0
Const WH_MOUSE = 7
Const GWL_HINSTANCE = (-6)

Dim hHook As LongPtr
Dim gbAbbruch As Boolean

Sub Mausabfrage()
 
 gbMausaktion = True
 hHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, _
         GetWindowLongPtr(Application.hWnd, GWL_HINSTANCE), _
         GetCurrentThreadId)
 
 Do
  DoEvents
  If gbAbbruch = True Then Exit Do
  If GetAsyncKeyState(27) <> 0 Then Exit Do 'Exit
 Loop
 
 gbMausaktion = False
 UnhookWindowsHookEx hHook                  'UnHook ist wichtig
 MsgBox "Aktion beendet!", vbInformation, "Maus..."
End Sub


Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, _
        lParam As MOUSEHOOKSTRUCT) As LongPtr
 On Error GoTo Fehler
 
 Select Case ncode
 Case HC_ACTION
    If lParam.hWnd > 0 Then
       Range("B1").Value = lParam.PT.x  'Mausposition X in Zelle ablegen
       Range("C1").Value = lParam.PT.y  'Mausposition Y in Zelle ablegen
          
       Select Case wParam
       Case WM_LBUTTONDOWN: Cells(1, 7) = Cells(1, 2)
       Case WM_RBUTTONDOWN: Cells(1, 8) = Cells(1, 3)
                            gbAbbruch = True
       Case WM_LBUTTONUP, WM_RBUTTONUP
       End Select
       
    End If
 Case Else
    MouseProc = CallNextHookEx(hHook, ncode, wParam, lParam)
 End Select

Fehler:
End Function

____________________
viele Grüße aus Freigericht
Karl-Heinz

viele Grüße
Karl-Heinz

Forumthread: IF Then Mausabfrage

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial