Get cursor position inside a rectangle

  • A+
Category:Languages

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:

Get cursor position inside a rectangle

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:

Get cursor position inside a rectangle

the coordinates that my plan returned weren't the expected near 0 coordinates I thought:

Get cursor position inside a rectangle

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.


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:

Get cursor position inside a rectangle

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.

Comment

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: