Get cursor position inside a rectangle

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:

1. Ensures the shape worksheet is active (application.WindowState could be either xlNormal or xlMaximized)
2. Set the shape object
3. Sets the shape range screen coordinates
4. 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