Consulting

Results 1 to 3 of 3

Thread: Move Shape with Cursor / Convert this VBA from Excel

  1. #1
    VBAX Regular
    Joined
    Feb 2022
    Posts
    37
    Location

    Move Shape with Cursor / Convert this VBA from Excel

    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

  2. #2
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,158
    Location
    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
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved

    Excel 365, Version 2401, Build 17231.20084

  3. #3
    VBAX Regular
    Joined
    Feb 2022
    Posts
    37
    Location
    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!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •