# Centering a shape on the mouse cursor

#### MorganO

##### Active Member
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:

Code:
``````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

### Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
L

#### Legacy 98055

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

#### MorganO

##### Active Member
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

L

#### Legacy 98055

##### Guest
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...

Code:
``````'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``````

L

#### Legacy 98055

##### Guest
Cannot edit my post?

<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

##### Active Member
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

##### New Member
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.
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

##### New Member
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

##### New Member
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:
VBA Code:
``````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

##### New Member
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.

Replies
1
Views
366
Replies
17
Views
1K
Replies
1
Views
512
Replies
3
Views
903
Replies
8
Views
4K

1,190,615
Messages
5,981,946
Members
439,746
Latest member
VBANewbieJohn

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back