Получить позицию курсора внутри прямоугольника

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

Вы почти у цели с вашим кодом.Однако в приложении 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 координату, потому что событие нажатиястреляет, даже если вы слегка отклоняетесь от фигуры.Вы можете легко поймать это в своей функции.

Answer 2

Это решение генерирует координаты экрана формы, выполнив следующие действия:

1. Гарантирует, что рабочий лист формы активен (application.WindowState может быть либо xlNormal, либо xlMaximized)
2. Установить объект формы
3. Устанавливает координаты экрана диапазона формы
4. Устанавливает координаты экрана формы путем сканирования координат экрана диапазона формы

Это решение не требует выравнивания формы по ячейкам.

Успешно протестировано для следующих ситуаций:

а) Окно Excel на экране ноутбука, WindowState = xlNormal

б) Окно Excel на экране ноутбука, WindowState = xlMaximized

в) Окно 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

Функция GetDC

Функция ReleaseDC

Процедура Visual Basic для получения / установки положения курсора

Answer 3

Ваша первая проблема - это Points.X & Points.Y, которые не относятся к документу или настройке отдельного монитора клиента, забудьте о настройке нескольких мониторов. Например, если курсор pos = (1000 500), но приложение не работает в полноэкранном режиме, необходимо учитывать Application.Left / Application.Top значений.

Несмотря на это, это не совсем точное представление о том, где находится ваша фигура. rectang.Left / rectang.Top не относятся к электронной таблице, как вы упоминаете, они относятся к объекту электронной таблицы или окну, если хотите. Это означает, что если бы вы переместили прямоугольник полностью влево и вверх по таблице, это было бы (0,0). Как показано ниже:

Теперь, допустим, мы удаляем заголовки столбцов, а также строку формулы из объекта ActiveWindow, координаты сохраняют свою позицию, как показано ниже:

Очевидно, что размер среды приложения изменился, а не прямоугольник. Левая позиция. При этом положение курсора Application.Top + rectang.Top никогда не будет истинным представлением того, где находится верх прямоугольника, если вы не учтете все эти обстоятельства времени выполнения.

Допустим, вы учитываете это, у вас есть доступ к некоторым настройкам с помощью объекта ActiveWindow, например Application.ActiveWindow.DisplayHeadings, и вы действительно стараетесь, чтобы эти проблемы не возникали. У вас все еще есть куча пользовательских предпочтений, которые нужно учитывать, т.е. отображаемые полосы прокрутки для учета, вкладки, фактическая лента, которые могут быть или не быть одинакового размера для клиентов, минимизированы или развернуты, макеты страниц, каков текущий уровень масштабирования Одно только вызовет конфликты, и не забывайте о панелях контента. Давайте возьмем, к примеру, панель окна формата формы, переместив ее влево от приложения и изменив ее размер до противной ширины, определенной пользователем:

Координаты по-прежнему сохраняют свое относительное положение, которое не будет коррелировать с положением курсора независимо от того, к каким свойствам у вас есть доступ, поскольку оно всегда будет зависеть от настроек среды пользователя.

В настоящее время мой ответ будет состоять в том, чтобы сказать, что не существует разумного «готового» метода для этого, а также по другой простой причине: у объектов Shape в Excel нет обработчиков событий для таких вещей, как onclick. или иным образом, кроме Worksheet.SelectionChange не срабатывает выбор Shapes afaik. Вы могли бы потенциально найти «хакерский» способ, запустив цикл для постоянной проверки текущего выбора и т. Д., Но, естественно, это нежелательно по соображениям производительности.

В качестве встроенного средства для достижения этой цели, до тех пор, пока для объектов Shape не будут добавлены обработчики событий, лучше всего было бы перенести это на COM AddIn или заполнить какую-то форму VBA Windows на рабочем листе, где у вас есть больше контролировать позиции клиента, все манипуляции с формой в форме, а затем добавить конечный продукт в электронную таблицу, когда пользователь будет готов.

Answer 4

Как я уже сказал, я получил то, что хочу, после изучения идеи, выданной мне @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 5

Новая редакция

Посмотрите на следующий код. Основная идея заключается в том, чтобы использовать 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