Get cursor position inside a rectangle - excel

Question

How do I get the coordinates of the cursor position relative to a rectangle (the one I use to call the macro)?
Here what I got this far:
First: I use the function:
Declare PtrSafe Function GetCursorPos Lib "user32" (Point As POINTAPI) As Long
Type POINTAPI
X As Long
Y As Long
End Type
to get the coordinates of the cursor on the screen. Those values are returned by:
Point.X 'pixels to the left of the screen
Point.Y 'pixels to the top of the screen
Second: I created a rectangle like this:
and set the following macro to it:
Sub SH03G13()
Dim Point As POINTAPI: GetCursorPos Point
Dim rectang As Shape: Set rectang = ThisWorkbook.Sheets("Sheet1").Shapes("SH03G13BACK")
Dim ABCISSA As Long: ABCISSA = Point.X - rectang.Left
Dim ORDENAD As Long: ORDENAD = Point.Y - rectang.Top
MsgBox ABCISSA & " " & ORDENAD
End Sub
On my mind, when I did this, I was positive I was getting the coordinates of the cursor inside the green rectangle. However, when I clicked on the black spot on the next image:
the coordinates that my plan returned weren't the expected near 0 coordinates I thought:
Then I realized that the GetCursorPos were returning the position of the cursor relative to the screen while the rectang.Left and rectang.Top commands on my script were returning the position of the rectangle relative to the spreadsheet. So, the lines Point.X - rectang.Left and Point.X - rectang.Left couldn't possibly be right.
Any ideas how I could get the correct coordinates? i.e How can I get the right coordinates near 0 by clicking on the black spot?
Any help will be very appreciated. And, as always, thank you all in advance.

Answer 1

As I told, I got what I want after exploring an idea gived to me by #Luuklag (by aligning the rectangle with a range of cells).
First I put the next code on a different module (just for a well organized code matter):
Option Explicit
Type RECT
Left As Long: Top As Long: Right As Long: Bottom As Long
End Type
Type POINTAPI
X As Long: Y As Long
End Type
Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Declare PtrSafe Function GetCursorPos Lib "user32" (Point As POINTAPI) As Long
Function ScreenDPI(bVert As Boolean) As Long
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&)
lDPI(1) = GetDeviceCaps(lDC, 90&)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Function PTtoPX(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window: Set wnd = rng.Parent.Parent.Windows(1)
With rng
rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)
rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)
rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + rc.Left
rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + rc.Top
End With
End Sub
After this, I set the rectangle with the next macro:
Sub SH03G13()
With ThisWorkbook.Sheets("Sheet1")
Dim AreaRng As Range: Set AreaRng = .Range(.Cells(2, 2), .Cells(13, 10))
Dim rectang As Shape: Set rectang = .Shapes("SH03G13BACK")
rectang.Height = AreaRng.Height
rectang.Width = AreaRng.Width
rectang.Top = AreaRng.Top
rectang.Left = AreaRng.Left
DoEvents
Dim Point As POINTAPI: GetCursorPos Point
Dim rc As RECT: Call GetRangeRect(.Cells(2, 2), rc)
Dim ABCISSA As Long: ABCISSA = Point.X - rc.Left
Dim ORDENAD As Long: ORDENAD = Point.Y - rc.Top
End With
MsgBox "x: " & ABCISSA & ", y: " & ORDENAD
End Sub
The previous macro places and adjusts the rectangle SH03G13BACK to the .Cells(2, 2), .Cells(13, 10) range. Once this is done, the Point.X - rc.Left and Point.Y - rc.Top commands gave me the exact coordinates inside the rectangle (and relative to it), regardless the maximized/minimized state of the excel window, the zoom value, the size/contents of the excel command ribbon or the size/resolution of the screen itself. It's perfect:
I realize this is a little cheating (I know that the GetRangeRect subroutine gives the coordinates relative to the .Cells(2, 2) position. However, for this matter, the trick works like a charm.

Answer 2

Your first problem is Points.X & Points.Y are not relative to the document or the clients individual monitor setup, forget about multi-monitor setups. For example, if the cursor pos = (1000,500) but the application isn't full screen, you have to take into account Application.Left / Application.Top values.
Even so, this isn't a true depiction of where your shape is. rectang.Left / rectang.Top are not relative to the spreadsheet as you mention, they are relative to the spreadsheet object, or window if you will. Meaning, if you were to move the rectangle all the way to the left and top of the spreadsheet it would be (0,0). As show below:
Now, lets say we remove the column headings as well as the formula bar from the ActiveWindow object, the coordinates maintain their position, as shown below:
Clearly they Application environment size has changed, not the rectang.Left position. With that being said, a cursor position of Application.Top + rectang.Top will never be a true representation of where the top of the rectangle is, unless you account for all these run-time circumstances.
Let's say you do take these into account, you do have access to some settings with the ActiveWindow object, like Application.ActiveWindow.DisplayHeadings, and you do make sure you do your best to omit these concerns. You still have a bunch of user preferences to consider, i.e, displayed scrollbars to account for, tabs, the actual ribbon, which may or may not be the same size across clients, minimized or maximized, page layouts, what the current zoom level is alone will cause conflicts, and don't forget about content panes. Let's take, for example, the format shape window pane, moving it to the left of the application and resizing it to an obnoxious width defined by a user:
The coordinates still maintain their relative position, which will not correlate to the cursor position regardless of what properties you have access to, because it will always depend on the user's environment settings.
At this time, my answer would be to say there is no reasonable 'out-of-the-box' method to accomplish this, also for another simple reason that Shape Objects in Excel do not have event handlers for things like onclick or otherwise, in addition to Worksheet.SelectionChange does not fire for selection of Shapes afaik. You could potentially find a "hacky" way by running a loop to continually check for current selection etc, but naturally this is not desired for performance reasons.
As a built in means of accomplishing this, until there are event handlers added for Shape Objects, your best bet might be to port this over to a COM AddIn or populate some kind of VBA Windows Form in the Worksheet where you have more control over client positions, do all your shape manipulation in the form, then add the final product to the spreadsheet when the user is done.

Answer 3

This solution generates the Shape Screen coordinates, following this steps:
Ensures the shape worksheet is active (application.WindowState could be either xlNormal or xlMaximized)
Set the shape object
Sets the shape range screen coordinates
Sets the shape screen coordinates by scanning shape range screen coordinates
This solutions does not need the shape to be aligned to the cells.
Tested successfully for the following situations:
a) Excel window in laptop screen, WindowState =xlNormal
b) Excel window in laptop screen, WindowState =xlMaximized
c) Excel window in alternate screen, WindowState =xlNormal
d) Excel window in alternate screen, WindowState =xlMaximized
These are the procedures:
Option Explicit
Public Type RgCrds
Top As Long
Left As Long
Right As Long
Bottom As Long
End Type
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Public Function Shape_ƒCoordinates_Get(uSpCrds As RgCrds, sp As Shape) As Boolean
Dim wd As Window, rg As Range, oj As Object
Dim uSpOutput As RgCrds, uRgCrds As RgCrds
Dim lX As Long, lY As Long
Dim blX As Boolean, blY As Boolean
Dim b As Byte
On Error GoTo Exit_Err
Rem Set Shape Worksheet Window
sp.TopLeftCell.Worksheet.Activate
Set wd = ActiveWindow
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rem Set Shape Range
Set rg = Range(sp.TopLeftCell, sp.BottomRightCell)
Rem Get Shape Range Coordinates
Call Range_ScreenCoordinates_Get(uRgCrds, rg)
Rem Set Shape Coordinates Limites
With uSpOutput
.Top = uRgCrds.Bottom
.Left = uRgCrds.Right
.Right = uRgCrds.Left
.Bottom = uRgCrds.Top
End With
Rem Scan Shape Range to Get Shape Coordinates - [TopLeft Corner]
blX = False: blY = False
For lX = uRgCrds.Left To uRgCrds.Right
For lY = uRgCrds.Top To uRgCrds.Bottom
Set oj = wd.RangeFromPoint(lX, lY)
If TypeName(oj) <> "Range" Then
If oj.ShapeRange.Type = sp.Type And oj.Name = sp.Name Then
Shape_ƒCoordinates_Get = True
With uSpOutput
If lY < .Top Then .Top = lY Else blX = True
If lX < .Left Then .Left = lX Else blY = True
If blX And blY Then Exit For
End With: End If: End If: Next: Next
Rem Scan Shape Range to Get Shape Coordinates [BottomRight Corner]
blX = False: blY = False
For lX = uRgCrds.Right To uRgCrds.Left Step -1
For lY = uRgCrds.Bottom To uRgCrds.Top Step -1
Set oj = wd.RangeFromPoint(lX, lY)
If TypeName(oj) <> "Range" Then
If oj.ShapeRange.Type = sp.Type And oj.Name = sp.Name Then
Shape_ƒCoordinates_Get = True
With uSpOutput
If lX > .Right Then .Right = lX Else: blX = True
If lY > .Bottom Then .Bottom = lY Else: blY = True
If blX And blY Then Exit For
End With: End If: End If: Next: Next
Rem Coordinates Fine-Tuning
' The RangeFromPoint Method recognizes the Shapes,
' as soon as any part of the cursor is over the shape,
' therefore some fine-tuning is required in order
' to place the entire mouse inside the Shape's body
b = 15 'change as required
With uSpOutput
.Top = .Top + b
.Left = .Left + b
.Right = .Right - b
.Bottom = .Bottom - b
End With
Rem Set Results
uSpCrds = uSpOutput
Shape_ƒCoordinates_Get = True
Exit_Err:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
Public Sub Range_ScreenCoordinates_Get(uOutput As RgCrds, ByVal rg As Range)
Dim wd As Window
With rg
Rem Activate range's worksheet window
.Worksheet.Activate
Application.Goto .Worksheet.Cells(1), 1
Set wd = ActiveWindow
Rem Set Range Screen Coordinates
uOutput.Top = Points_ƒToPixels(.Top * wd.Zoom / 100, 1) + wd.PointsToScreenPixelsY(0)
uOutput.Left = Points_ƒToPixels(.Left * wd.Zoom / 100, 0) + wd.PointsToScreenPixelsX(0)
uOutput.Right = Points_ƒToPixels(.Width * wd.Zoom / 100, 0) + uOutput.Left
uOutput.Bottom = Points_ƒToPixels(.Height * wd.Zoom / 100, 1) + uOutput.Top
End With
End Sub
Private Function Points_ƒToPixels(sgPoints As Single, blVert As Boolean) As Long
Points_ƒToPixels = sgPoints * Screen_ƒDPI(blVert) / 72
End Function
Private Function Screen_ƒDPI(blVert As Boolean) As Long
Static lDPI(0 To 1) As Long, lDC As Long
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&)
lDPI(1) = GetDeviceCaps(lDC, 90&)
lDC = ReleaseDC(0, lDC)
End If
Screen_ƒDPI = lDPI(Abs(blVert))
End Function
Copy the procedures above in a standard module then copy this procedure in a separated module
Option Explicit
Sub Shape_Coordinates_Get_TEST()
Dim ws As Worksheet
Dim sp As Shape
Dim uSpCrds As RgCrds
Rem Set Target Worksheet Active Window
Set ws = ThisWorkbook.Worksheets("SO_Q50293831") 'replace as required
With ws
.Activate
Set sp = .Shapes("SH03G13BACK")
End With
Rem Get Shape Coordinates
If Not (Shape_ƒCoordinates_Get(uSpCrds, sp)) Then Exit Sub 'might want to add a message
Rem Apply Shape Coordinates
With uSpCrds
SetCursorPos .Left, .Top: Stop ' Mouse is now at the Shape's TopLeft corner
SetCursorPos .Left, .Bottom: Stop ' Mouse is now at the Shape's LeftBottom corner
SetCursorPos .Right, .Top: Stop ' Mouse is now at the Shape's RightTop corner
SetCursorPos .Right, .Bottom: Stop ' Mouse is now at the Shape's BottomRigh corner
End With
End Sub
For additional information about the resources used visit these pages:
GetDeviceCaps function
GetDC function
ReleaseDC function
Visual Basic Procedure to Get/Set Cursor Position

Answer 4

NEW EDITED VERSION
Take a look at the following code. The core idea is to use RangeFromPoint, that returns the Shape or Range object that is positioned at the specified pair of screen coordinates.
There logical steps are:
1) get the clicking position and screen dimensions (in pixels).
2) get the first two cells in the visible range that belongs to different row/column, and get their 'excel' position as well as their pixel position.
3) Calculate the relation between 'Excel units' and pixels.
4) scan all shapes in worksheet, take their excel position and calculate their pixel position.
Although a little verbose (not too long, if you delete all lines for writing variables to sheet), I think the code is rather straight, without the need for positioning shapes along cells or checking zoom or similar. You can have many shapes in the sheet, and assign the code to all of them.
The only requirement is that the four cell on the top-left corner of the visible window must not be covered by a shape.
The below code is writing the different variables in the sheet, just for clarity.
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long
Private Type POINT
x As Long
y As Long
End Type
Public Declare Function GetSystemMetrics Lib "user32.dll" (ByVal index As Long) As Long
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Sub GetPixelsFromImageBorder()
Dim pLocation As POINT
Dim objShape As Object
Dim ScreenWidth As Integer
Dim ScreenHeight As Integer
Dim xPix As Integer, yPix As Integer
Dim Cell_1_X As Double, Cell_1_Y As Double
Dim Cell_2_X As Double, Cell_2_Y As Double
Dim Cell_1_Row As Integer, Cell_1_Col As Integer
Dim Cell_2_Row As Integer, Cell_2_Col As Integer
Dim Cell_1_X_Pix As Double, Cell_1_Y_Pix As Double
Dim Cell_2_X_Pix As Double, Cell_2_Y_Pix As Double
Dim Y0 As Double, X0 As Double
Dim SlopeX As Double, SlopeY As Double
Dim flg1 As Boolean, flg2 As Boolean, flg3 As Boolean
Dim WhichWS As Worksheet
Dim w As Window, r As Range, cll As Range
Dim Shp As Shape
Call GetCursorPos(pLocation)
Set WhichWS = Worksheets("Sheet1")
WhichWS.Range("A1:H20").ClearContents
ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
ClickX = pLocation.x
ClickY = pLocation.y
WhichWS.Cells(3, 1) = "Variable"
WhichWS.Cells(3, 1).Font.Bold = True
WhichWS.Cells(3, 2) = "X"
WhichWS.Cells(3, 2).Font.Bold = True
WhichWS.Cells(3, 3) = "Y"
WhichWS.Cells(3, 3).Font.Bold = True
WhichWS.Cells(4, 1) = "Screen (in pixels): "
WhichWS.Cells(4, 2) = ScreenWidth
WhichWS.Cells(4, 3) = ScreenHeight
WhichWS.Cells(5, 1) = "Mouse clicked on (in pixels): "
WhichWS.Cells(5, 2) = ClickX
WhichWS.Cells(5, 3) = ClickY
Set w = ActiveWindow
Set r = w.VisibleRange
i = 1
For Each cll In r.Cells
If i = 1 Then
'get top and right pos (in excel units) of first cell in visible range
'also get row and column of that cell
Cell_1_Y = cll.Top
Cell_1_X = cll.Left
Cell_1_Row = cll.Row
Cell_1_Col = cll.Column
i = i + 1
ElseIf cll.Row > Cell_1_Row And cll.Column > Cell_1_Col Then
'get top and right pos (in excel units) of second cell in visible range
'also get row and column of that cell
Cell_2_Y = cll.Top
Cell_2_X = cll.Left
Cell_2_Row = cll.Row
Cell_2_Col = cll.Column
Exit For
End If
Next
On Error Resume Next
flg1 = False
flg2 = False
flg3 = False
For yPix = 1 To ScreenHeight
For xPix = 1 To ScreenWidth
Set objShape = ActiveWindow.RangeFromPoint(xPix, yPix)
If Not objShape Is Nothing Then
If TypeName(objShape) = "Range" Then
If objShape.Column = Cell_1_Col And objShape.Row = Cell_1_Row Then
'get top and right pos (in pix) of first cell in visible range
If flg2 = False Then
Cell_1_X_Pix = xPix
Cell_1_Y_Pix = yPix
flg2 = True
End If
ElseIf objShape.Column = Cell_2_Col And objShape.Row = Cell_2_Row Then
'get top and right pos (in pix) of second cell in visible range
If flg3 = False Then
Cell_2_X_Pix = xPix
Cell_2_Y_Pix = yPix
flg3 = True
flg1 = True 'exit of outer loop
Exit For 'exit inner loop (this)
End If
End If
End If
End If
Next
If flg1 = True Then Exit For
Next
'Calculate the relation between pixels and 'excel position'
SlopeY = (Cell_2_Y_Pix - Cell_1_Y_Pix) / (Cell_2_Y - Cell_1_Y)
Y0 = Cell_1_Y_Pix - SlopeY * Cell_1_Y
SlopeX = (Cell_2_X_Pix - Cell_1_X_Pix) / (Cell_2_X - Cell_1_X)
X0 = Cell_1_X_Pix - SlopeX * Cell_1_X
'print some variables in sheet
WhichWS.Cells(6, 1) = "Variable"
WhichWS.Cells(6, 1).Font.Bold = True
WhichWS.Cells(6, 2) = "X Pos (excel units)"
WhichWS.Cells(6, 2).Font.Bold = True
WhichWS.Cells(6, 3) = "Y Pos (excel units)"
WhichWS.Cells(6, 3).Font.Bold = True
WhichWS.Cells(6, 4) = "X Pos (pixels)"
WhichWS.Cells(6, 4).Font.Bold = True
WhichWS.Cells(6, 5) = "Y Pos (pixels)"
WhichWS.Cells(6, 5).Font.Bold = True
WhichWS.Cells(6, 6) = "X Dist. from click (pixels)"
WhichWS.Cells(6, 6).Font.Bold = True
WhichWS.Cells(6, 7) = "Y Dist. from click (pixels)"
WhichWS.Cells(6, 7).Font.Bold = True
i = 7
For Each Shp In WhichWS.Shapes
WhichWS.Cells(i, 1) = Shp.Name
WhichWS.Cells(i, 2) = Shp.Left
WhichWS.Cells(i, 3) = Shp.Top
PosInPixX = X0 + Shp.Left * SlopeX
PosInPixY = Y0 + Shp.Top * SlopeY
DistFromClickX = ClickX - PosInPixX
DistFromClickY = ClickY - PosInPixY
WhichWS.Cells(i, 4) = Round(PosInPixX, 2)
WhichWS.Cells(i, 5) = Round(PosInPixY, 2)
WhichWS.Cells(i, 6) = DistFromClickX
WhichWS.Cells(i, 7) = DistFromClickY
i = i + 1
Next Shp
End Sub

Answer 5

You are nearly there with your code. However Excel App has ribbon that takes some space. In this case, ActiveWindow.PointsToScreenPixelsX(0) and ActiveWindow.PointsToScreenPixelsY(0) will return your worksheet starting pixels relative to the screen.
Now the (mousePos) - (worksheet position) - (left and top of the shapeIn Pixel) will give you mouse position relative to your shape.
Try this code:
Public Function SH03G13()
Dim point As POINTAPI: GetCursorPos point
Dim rectang As Shape: Set rectang = ThisWorkbook.Sheets("Sheet1").Shapes("SH03G13BACK")
Debug.Print "Mouse pointer relative to screen:", point.X, point.Y
Debug.Print "Mouse pointer relative to app:", (point.X - ActiveWindow.PointsToScreenPixelsX(0)), (point.Y - ActiveWindow.PointsToScreenPixelsY(0))
Debug.Print "Mouse pointer relative to shape:", ((point.X - ActiveWindow.PointsToScreenPixelsX(0)) - PointToPixel(rectang.Left)), ((point.Y - ActiveWindow.PointsToScreenPixelsY(0)) - PointToPixel(rectang.Top))
Dim ABCISSA As Long: ABCISSA = point.X - rectang.Left
Dim ORDENAD As Long: ORDENAD = point.Y - rectang.Top
'Debug.Print ABCISSA & " " & ORDENAD
End Function
Public Function PointToPixel(point As Double) As Double
'Converts points to pixel
If point > 0 Then PointToPixel = Round((1.33333333333333 * point), 2) Else PointToPixel = 0
End Function
results in your immediate window will be:
Mouse pointer relative to screen: 410 356
Mouse pointer relative to app: 384 313
Mouse pointer relative to shape: 0 0
Note: You might get -1 coordinates, that's because the on click event fires even if you click slightly away from the shape. You can catch this easily in your function.