[Excel] API - Position von Shapes überwachen...

[00202]

Moin,

nachfolgend eine kleine API Funktion, welche die Position eines Shapes überwacht. Kann z. B. genutzt werden, wenn (M)man(n) überprüfen möchte, ob etwas an der richtigen Position ist bzw. verschoben wurde.

Der Code:

Code:

Option Explicit
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private lngTimer As LongPtr
    Dim dblXAchse As Double
    Dim dblYAchse As Double
    Private shpShape As Shape
Sub StartTimer()
    Set shpShape = Tabelle1.Shapes("Ellipse 2")
    dblXAchse = shpShape.Top
    dblYAchse = shpShape.Left
    lngTimer = SetTimer(0, 0, 300, AddressOf CheckShape)
End Sub
Sub StopTimer()
    KillTimer 0, lngTimer
End Sub
Sub CheckShape()
    On Error Resume Next
    With shpShape
        If .Top <> dblXAchse Or .Left <> dblYAchse Then
            StopTimer
            shpShape.Top = dblXAchse
            shpShape.Left = dblYAchse
            Set shpShape = Nothing
            MsgBox "Kreis bewegt!"
            StartTimer
        End If
    End With
    On Error GoTo 0
End Sub

Und die Datei.  
[attachment=48533]