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＆amp; 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，并确保您尽力省略这些顾虑。您仍然需要考虑一堆用户首选项，即显示滚动条以进行说明，制表符，实际功能区，在客户端，最小化或最大化，页面布局可能是也可能不同，当前缩放级别是什么单独会引起冲突，不要忘记内容窗格。例如，让我们采用格式形状窗口窗格，将其移动到应用程序的左侧，并将其大小调整为用户定义的令人讨厌的宽度：

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

目前，我的答案是说没有合理的开箱即用的＆＃39;实现这一目标的方法，另外一个简单的原因是Excel中的Shape Objects没有像onclick或其他东西那样的事件处理程序，除了Worksheet.SelectionChange之外不会触发选择Shapes afaik。你可能会找到一个＆＃34; hacky＆＃34;通过运行循环来连续检查当前选择等的方式，但自然这不是出于性能原因所希望的。

作为实现此功能的内置方法，在为Shape Objects添加事件处理程序之前，最好的办法是将其移植到COM AddIn或在工作表中填充某种VBA Windows窗体，其中包含更多内容控制客户位置，在表单中执行所有形状操作，然后在用户完成后将最终产品添加到电子表格中。

Answer 3

新编辑版

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

逻辑上的步骤是：
1）获取点击位置和屏幕尺寸（以像素为单位） 2）获取属于不同行/列的可见范围中的前两个单元格，并获得他们的＆＃39; excel＆＃39;位置以及它们的像素位置 3）计算Excel单位＆＃39;之间的关系。和像素 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 4

此解决方案按照以下步骤生成“形状屏幕”坐标：

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

此解决方案不需要将形状与细胞对齐。

在以下情况下成功测试：

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 5

你的代码几乎就在那里。但是，Excel App具有占用一些空间的功能区。在这种情况下，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坐标，因为即使您稍微远离形状，点击事件也会触发。您可以在功能中轻松捕捉到这一点。

获取光标在矩形内的位置

5 个答案: