Centering a shape on the mouse cursor

[MorganO]

I have been learning to manipulate shapes in VBA and have come across a problem that I can't quite crack. I am attempting to have a worksheet shape autocenter itself on my mouse pointer as I move the mouse. It nearly works, but the shape does not quite land on the mouse cursor as it should - it is offset down and to the right.

I know that the problem lies within the difference between the values returned for the mouse position (the entire Excel Window) versus the position returned for the shape object (the worksheet Window) [Due to the toolbars and row 'header'] but I just can't seem to find a proper solution for determining the proper 'offset' factor.

Can someone point me in the right direction?

I've attached the code I have so far below:

Sub MouseMoveObjectTest()
Dim lngCurPos As POINTAPI
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
Do
 
GetCursorPos lngCurPos
 
' Find the Center of the Stationary and Moving Object
CenterRowStationary = lngCurPos.Y
CenterColStationary = lngCurPos.x
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

Thanks.

Owen

 

[Legacy 98055]

Are you simply wanting a shape that will "smoothly" chase the cursor?

 

[MorganO]

Yes, that is basically what I am attempting to do with the code I am working with.

When I move the mouse I would like the shape to follow the the most direct line to the current mouse location and if it catches the mouse, to center itself on the mouse.

The code I have will do all of that if I have one shape chase another shape. Just isn't working if I replace the chased shape with the mouse cursor.


Owen

 

[Legacy 98055]

Well... I was trying to dig up an old project that your code reminded me of. Back when the Office Assistant was "cool". I know, that was really never. Anyway, I played a gag on some co-workers in which my buddy the paper clip would glide down and delete whatever the user had just entered and then glide back up to the right hand corner waiting for the next opportunity. Could not find it... History lesson ends here.

You have to convert your screen coords to doc pts. See the code. Some things to consider. Window resizing, scrolling, zoom settings, and perhaps some other actions will break your code. All of the mentioned can be accounted for but I did not bother because I don't know if it's neccesary. Let me know...

'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

 

[Legacy 98055]

Cannot edit my post?

Here is a link to an example using your code...

<a href="http://home.fuse.net/tstom/ShapeKeepAway.zip"><img src="http://home.fuse.net/tstom/zip.gif"width="16"height="16"border="0"></a> <a href="http://home.fuse.net/tstom/ShapeKeepAway.zip">ShapeKeepAway.zip</a>

 

[MorganO]

Thanks so much for your quick reply! The worksheet works perfectly. I actually remember seeing your name pop up in a lot of the posts I was using to help me with the initial coding for the mouse position - this must be one of your specialty areas!

I will study this and see what I can learn!

Take care,

Owen

P.S. Post editing can only be done within the first few minutes after posting - it is done this way to limit database corruption problems.

 

[Greg77]

hi Tom,
i'm seriously interested in your solution on following the mouse cursor, regardless of resizing, scrolling or zooming the active spreadsheet window. i'm trying to move the cell selection according to mouse movement, but these adjustments ruin the functioning of my code.
thank you for your help in advance
greg

Some things to consider. Window resizing, scrolling, zoom settings, and perhaps some other actions will break your code. All of the mentioned can be accounted for but I did not bother because I don't know if it's neccesary. Let me know...

 

[sswcharlie]

Hi

A bit late I know from original post.
I would like to download the .zip file above, posted by Tom Schreiner. Called ShapeKeepAway.zip Does not seem to be there anymore. Can someone help with the zip file. swchuck atat gmail dot com
Thanks
Charles Harris

 

[mightyMagnus]

An alternative: Use ActiveX Image Control.
Make use of its MouseMove Event whose X and Y returns the coordinates of the point when the mouse cursor mouse over; avoiding the need to use GetCursorPosition API and not need to deal with scrolling, zooming, multiple monitors, etc problems that come with using the mouse cursor position DLL.

Code reference to make shape/picture move according to your mouse:

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim shp as Shape    
    Set shp = ActiveSheet.Shapes("Rectangle 1")
    With shp
        .Visible = True
        .Left = (Image1.Left + X) - (shp.Width / 2)
        .Top = Image1.Top + Y - (shp.Height / 2)
    End With

Mouse cursor can also be hidden under the image control properties.
Set MousePointer property to be "99 - fmMousePointerCustom" and MouseIcon to load an icon (.ico) /cursor (.cur) file that has no fill (transparent).

 

[DodgyBazaar]

Hi All,
Could MorganO / Legacy 98055 's code be adapted for PowerPoint?
I've been trying to transcribe it to a PPT for hours but I'm afraid it's over my head. Any help would be much appreciated.