Move Shape with Cursor / Convert this VBA from Excel

[Kellaroo]

Hi All !
Could this code be successfully converted to work in PowerPoint?
It's intended to make a shape smoothly follow the mouse cursor. I've been trying to transcribe it for hours but I'm afraid it's over my head. Any help or alternatives to getting a shape to follow the mouse cursor would be much appreciated. Thank you for your consideration!



'Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Sub MouseMoveObjectTest()
Dim lngCurPos As POINTAPI
Dim DocZero As POINTAPI
Dim PointsPerPixelY As Double
Dim PointsPerPixelX As Double
Dim hdc As Long

For Each sp In Worksheets("Sheet1").Shapes
sp.Delete
Next

Set a = Worksheets("Sheet1").Shapes.AddShape(92, 50, 50, 20, 20)
a.Name = "Oval2"
a.Fill.ForeColor.SchemeColor = False

hdc = GetDC(0)
PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
ReleaseDC 0, hdc

DocZero.Y = ActiveWindow.PointsToScreenPixelsY(0)
DocZero.X = ActiveWindow.PointsToScreenPixelsX(0)

Do

GetCursorPos lngCurPos

' Find the Center of the Stationary and Moving Object
CenterRowStationary = (lngCurPos.Y - DocZero.Y) * PointsPerPixelY
CenterColStationary = (lngCurPos.X - DocZero.X) * PointsPerPixelX
CenterRowMoving = Shapes("Oval2").Top + Shapes("Oval2").Height / 2
CenterColMoving = Shapes("Oval2").Left + Shapes("Oval2").Width / 2

MovementSpeed = 1.25

' Now comes the hard part. I want the object to follow a straight path to the stationary
' object, so I will need to use Right Triangle Math to do this.
' First, I need to determine the Hypotenus of the Right Triangle give the height and width
' of the right triangle
TriangleHeight = Abs(CenterRowStationary - CenterRowMoving)
TriangleWidth = Abs(CenterColStationary - CenterColMoving)
TriangleHyp = Sqr(TriangleHeight ^ 2 + TriangleWidth ^ 2)

' Ok, now I will need to use the movement speed (which is the hypotenuse of a smaller
' right triangle within the larger right triangle above) to determine the height and width
' of this new triangle. These values are directly proportional to the values in the above
' triangle.
If TriangleHeight = 0 Then
NewTriangleHeight = 0
Else
NewTriangleHeight = (TriangleHeight / TriangleHyp) * MovementSpeed
End If

If TriangleWidth = 0 Then
NewTriangleWidth = 0
Else
NewTriangleWidth = (TriangleWidth / TriangleHyp) * MovementSpeed
End If

' These new values are the row and column adjustment factors we will use to move
' the object.
With Shapes("Oval2")
If (.Top + Shapes("Oval2").Height / 2) > CenterRowStationary Then .Top = .Top - NewTriangleHeight
If (.Top + Shapes("Oval2").Height / 2) < CenterRowStationary Then .Top = .Top + NewTriangleHeight
If (.Left + Shapes("Oval2").Width / 2) > CenterColStationary Then .Left = .Left - NewTriangleWidth
If (.Left + Shapes("Oval2").Width / 2) < CenterColStationary Then .Left = .Left + NewTriangleWidth
End With

DoEvents
Loop
End Sub

[georgiboy]

I would not call it smooth but maybe you can play with the settings...

Maybe:

Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Sub MouseMoveObjectTest()
Dim lngCurPos As POINTAPI
Dim DocZero As POINTAPI
Dim PointsPerPixelY As Double
Dim PointsPerPixelX As Double
Dim hdc As Long
Dim sp As Shape, a As Shape
Dim CenterRowStationary As Double
Dim CenterColStationary As Double
Dim CenterRowMoving As Double
Dim CenterColMoving As Double
Dim MovementSpeed As Double
Dim TriangleHeight As Double
Dim TriangleWidth As Double
Dim TriangleHyp As Double
Dim NewTriangleHeight As Double
Dim NewTriangleWidth As Double

For Each sp In ActivePresentation.Slides(1).Shapes
sp.Delete
Next

Set a = ActivePresentation.Slides(1).Shapes.AddShape(92, 50, 50, 20, 20)
a.Fill.ForeColor.RGB = RGB(0, 75, 150)
hdc = GetDC(0)
PointsPerPixelY = 72 / GetDeviceCaps(hdc, 90)
PointsPerPixelX = 72 / GetDeviceCaps(hdc, 88)
ReleaseDC 0, hdc
DocZero.Y = ActiveWindow.PointsToScreenPixelsY(0)
DocZero.X = ActiveWindow.PointsToScreenPixelsX(0)

Do
GetCursorPos lngCurPos
CenterRowStationary = (lngCurPos.Y - DocZero.Y) * PointsPerPixelY
CenterColStationary = (lngCurPos.X - DocZero.X) * PointsPerPixelX
CenterRowMoving = a.Top + a.Height / 2
CenterColMoving = a.Left + a.Width / 2
MovementSpeed = 1
TriangleHeight = Abs(CenterRowStationary - CenterRowMoving)
TriangleWidth = Abs(CenterColStationary - CenterColMoving)
TriangleHyp = Sqr(TriangleHeight ^ 2 + TriangleWidth ^ 2)
If TriangleHeight = 0 Then
NewTriangleHeight = 0
Else
NewTriangleHeight = (TriangleHeight / TriangleHyp) * MovementSpeed
End If

If TriangleWidth = 0 Then
NewTriangleWidth = 0
Else
NewTriangleWidth = (TriangleWidth / TriangleHyp) * MovementSpeed
End If
With a
If (.Top + .Height / 2) > CenterRowStationary Then .Top = .Top - NewTriangleHeight
If (.Top + .Height / 2) < CenterRowStationary Then .Top = .Top + NewTriangleHeight
If (.Left + .Width / 2) > CenterColStationary Then .Left = .Left - NewTriangleWidth
If (.Left + .Width / 2) < CenterColStationary Then .Left = .Left + NewTriangleWidth
End With
DoEvents
Loop
End Sub

[Kellaroo]

You got it to work! Definitely more than I could do, though I see now I was very close in my initial attempt. Thanks for getting it this far : )

Like you said though, it's not very smooth. When I think about the code, it's hard to understand why. Like it shouldn't be too much to process, but it looks so glitchy.
If I ever figure out how to improve it, I'll share here!