IF Then Mausabfrage

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc][+][-] Option Explicit Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Const VK_RBUTTON = &H2 Const VK_LBUTTON = &H1 Type POINTAPI x As Long y As Long End Type Sub Mausabfrage() Dim Pos As POINTAPI Do DoEvents If GetAsyncKeyState(VK_RBUTTON) > 0 Then Exit Do GetCursorPos Pos Range("B1").Value = Pos.x Range("C1").Value = Pos.y If GetAsyncKeyState(VK_LBUTTON) > 0 Then 'Linie Zeichnen Beep End If Sleep 100 Loop End Sub

Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Const VK_RBUTTON = &H2 Const VK_LBUTTON = &H1 Type POINTAPI x As Long y As Long End Type Sub Mausabfrage() Dim Pos As POINTAPI Do DoEvents If GetAsyncKeyState(VK_RBUTTON) > 0 Then Cells(1, 8) = Cells(1, 3) GetCursorPos Pos Range("B1").Value = Pos.x Range("C1").Value = Pos.y If GetAsyncKeyState(VK_LBUTTON) > 0 Then Cells(1, 7) = Cells(1, 2) Sleep 100 Loop 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

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

Hallo
Es ist genau was ich wollte, sogar viel besser. Man kann nach unten und rechts zeichnen soweit man will.
Damit kann ich sogar bei der Drucker-Ansicht noch kleine Änderungen vornehmen.
Musste das Löschen abschalten, da damit alle schon vorhandenen Zeichnungen und Textfelder gelöscht werden.
Wenn löschen dann nur die damit gerade gezeichneten Linienfolge. Wenn die Linienfolge ein Fehler hatte. außer es wurde gespeichert, denn dann gehört es zum Plan und soll natürlich bleiben.
Was vielleicht noch haben möchte wäre ein Zielkreuz 11 x 11 Pixel als Mauszeiger. Da wäre das positionieren der Maus viel leichter auf den vorhanden Linien und anderen Formen.
Super wäre wenn Start und Endpunkt, bei der X oder Y Koordinate weniger als 5 Punkte Unterschied hat auf der Koordinate vom Startpunkt gezeichnet wird. Dann muss ich beim setzen des Endpunktes nicht so genau zielen.
zB. S-Punkt = 751,681 E-Punkt 367,683 gezeichnet dann SP 751,681 zu 367,681 Waagrecht
zB. S-Punkt = 13,45 E-Punkt 17,201 gezeichnet dann SP 13,45 zu 13,201 Senkrecht
Berichtigung der Linien, nach oben, rechts, unten und links der Linien.
Bedanke mich herzlich gruß Aton

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

IF Then Mausabfrage

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread