获取矩形内的光标位置

Question

如何获得光标位置相对于矩形（我用来调用宏的那个）的坐标？ 这是我到目前为止得到的：

首先：我使用函数：

Declare PtrSafe Function GetCursorPos Lib "user32" (Point As POINTAPI) As Long
Type POINTAPI
   X As Long
   Y As Long
End Type

获取光标在屏幕上的坐标。这些值由以下人员返回：

Point.X 'pixels to the left of the screen
Point.Y 'pixels to the top of the screen

第二：我创建了一个这样的矩形：

并为其设置以下宏：

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

在我看来，当我这样做时，我很肯定我得到了绿色矩形内的光标坐标。但是，当我点击下一张图片上的黑点时：

我的计划返回的坐标不是我认为的预期接近 0 的坐标：

然后我意识到 GetCursorPos 正在返回光标相对于屏幕的位置，而我脚本上的 rectang.Left 和 rectang.Top 命令正在返回矩形相对于电子表格的位置。因此，Point.X - rectang.Left 和 Point.X - rectang.Left 行不可能是正确的。

任何想法如何获得正确的坐标？即如何通过单击黑点获得接近 0 的正确坐标？ 任何帮助将不胜感激。和往常一样，提前谢谢大家。

Answer 1

正如我所说，在探索了@Luuklag 给我的一个想法（通过将矩形与一系列单元格对齐）之后，我得到了我想要的。

首先我把下一个代码放在不同的模块上（只是为了一个组织良好的代码问题）：

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

在此之后，我用下一个宏设置矩形：

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

前面的宏将矩形SH03G13BACK 放置并调整到.Cells(2, 2), .Cells(13, 10) 范围。完成此操作后，Point.X - rc.Left 和 Point.Y - rc.Top 命令为我提供了矩形内（以及相对于它）的确切坐标，而不管 excel 窗口的最大化/最小化状态、缩放值、大小/内容excel 命令功能区或屏幕本身的大小/分辨率。很完美：

我意识到这有点作弊（我知道GetRangeRect 子例程给出了相对于.Cells(2, 2) 位置的坐标。但是，就这件事而言，这个技巧就像一个魅力。

Answer 2

您的第一个问题是 Points.X 和 Points.Y 与文档或客户端个人显示器设置无关，忘记多显示器设置。例如，如果光标 pos = (1000,500) 但应用程序不是全屏，则必须考虑 Application.Left / Application.Top 值。

即便如此，这并不是对您的形状位置的真实描述。 rectang.Left /rectang.Top 与您提到的电子表格无关，它们与电子表格对象或窗口相关，如果您愿意的话。意思是，如果您要将矩形一直移动到电子表格的左侧和顶部，它将是 (0,0)。如下图：

现在，假设我们从 ActiveWindow 对象中删除列标题以及编辑栏，坐标保持它们的位置，如下所示：

显然它们的应用环境大小已经改变，而不是rectang.Left 位置。话虽如此，除非您考虑到所有这些运行时情况，否则 Application.Top +rectang.Top 的光标位置永远不会真正代表矩形顶部的位置。

假设您确实考虑到了这些问题，您确实可以使用ActiveWindow 对象访问某些设置，例如Application.ActiveWindow.DisplayHeadings，并且您确实确保尽力忽略这些问题。您仍然需要考虑一堆用户偏好，即显示的滚动条，选项卡，实际的功能区，客户端之间的大小可能相同也可能不同，最小化或最大化，页面布局，当前缩放级别是什么单独会导致冲突，不要忘记内容窗格。让我们以格式形状窗口窗格为例，将其移动到应用程序的左侧，并将其调整为用户定义的令人讨厌的宽度：

坐标仍然保持它们的相对位置，无论您可以访问哪些属性，它都不会与光标位置相关，因为它始终取决于用户的环境设置。

此时，我的回答是说没有合理的“开箱即用”方法来实现这一点，还有一个简单的原因是 Excel 中的形状对象没有用于 onclick 之类的事件处理程序或以其他方式，除了Worksheet.SelectionChange 不会触发选择形状afaik。通过运行循环来不断检查当前选择等，您可能会找到一种“hacky”方式，但出于性能原因，这自然是不希望的。

作为实现这一点的内置方法，在为形状对象添加事件处理程序之前，最好的选择可能是将其移植到 COM 插件或在工作表中填充某种 VBA Windows 窗体控制客户位置，在表单中进行所有形状操作，然后在用户完成后将最终产品添加到电子表格中。

Answer 3

此解决方案生成形状屏幕坐标，遵循以下步骤：

1. 确保形状工作表处于活动状态（application.WindowState 可以是 xlNormal 或 xlMaximized）
2. 设置形状对象
3. 设置形状范围屏幕坐标
4. 通过扫描形状范围屏幕坐标设置形状屏幕坐标

此解决方案不需要将形状与单元格对齐。

在以下情况下测试成功：

a) 笔记本电脑屏幕中的 Excel 窗口，WindowState =xlNormal

b) 笔记本电脑屏幕中的 Excel 窗口，WindowState =xlMaximized

c) 备用屏幕中的 Excel 窗口，WindowState =xlNormal

d) 备用屏幕中的 Excel 窗口，WindowState =xlMaximized

这些是程序：

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

将上述过程复制到标准模块中，然后将此过程复制到单独的模块中

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

有关所用资源的更多信息，请访问以下页面：

GetDeviceCaps function

GetDC function

ReleaseDC function

Visual Basic Procedure to Get/Set Cursor Position

Answer 4

新编辑版本

看看下面的代码。核心思想是使用RangeFromPoint，返回位于指定屏幕坐标对的Shape或Range对象。

逻辑步骤是：
1) 获取点击位置和屏幕尺寸（以像素为单位）。
2) 获取前两个单元格属于不同行/列的可见范围，并获取它们的“excel”位置以及它们的像素位置。
3）计算“Excel单位”与像素之间的关系。
4) 扫描工作表中的所有形状，获取它们的 excel 位置并计算它们的像素位置。

虽然有点冗长（不要太长，如果你删除所有用于将变量写入工作表的行），我认为代码相当简单，不需要沿着单元格定位形状或检查缩放或类似的东西。您可以在工作表中有许多形状，并将代码分配给所有形状。

唯一的要求是可见窗口左上角的四个单元格不能被形状覆盖。

为了清楚起见，下面的代码在工作表中写入了不同的变量。

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

您的代码就快到了。但是 Excel 应用程序的功能区需要一些空间。在这种情况下，ActiveWindow.PointsToScreenPixelsX(0) 和 ActiveWindow.PointsToScreenPixelsY(0) 将返回工作表相对于屏幕的起始像素。

现在(mousePos) - (worksheet position) - (left and top of the shapeIn Pixel) 将为您提供相对于您的形状的鼠标位置。

试试这个代码：

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

您的即时窗口中的结果将是：

Mouse pointer relative to screen:          410           356 
Mouse pointer relative to app:             384           313 
Mouse pointer relative to shape:           0             0 

注意：您可能会得到 -1 坐标，这是因为即使您在距离形状稍远的地方单击也会触发 on click 事件。您可以在函数中轻松捕捉到这一点。