MS PowerPoint：如何将形状的位置和大小转换为屏幕坐标？

Question

我为 PowerPoint (2010) 写了一个小 VBA 宏，当鼠标悬停在某个形状上时，它会打开一个带有解释的弹出窗口。这工作正常。唉，再次离开该区域时不会触发任何事件，所以我现在想扩展代码，以便它监视弹出窗口的区域，当指针离开该区域时，它会再次删除弹出窗口。

但现在我遇到了一些愚蠢的问题：Shape 的坐标（.Left、.Top、.Width 和 .Height）以一些“文档单位”给出（不知道具体是什么单位） )。然而，指针坐标显然是以屏幕像素为单位的。为了能够合理地比较两者以计算指针是在内部还是外部，我需要首先将 Shape 的尺寸转换为屏幕像素。

我在 Google 上搜索了很多，但起初我发现了几个很有前途的代码 sn-ps，但这些都不起作用（因为大多数是用于 Excel，而 PowerPoint 显然具有不同的文档模型）。

能否有好心人给我一个提示或一些参考，如何将 Shape 的尺寸转换为屏幕像素（即考虑缩放、窗口位置、缩放因子等）。

M.

Answer 1

如果有人感兴趣 - 这是我经过大量进一步谷歌搜索后的解决方案：

Type POINTAPI
   x As Long
   y As Long
End Type

Type Rectangle
    topLeft As POINTAPI
    bottomRight As POINTAPI
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long

Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Function TransformShape(osh As Shape) As Rectangle
    Dim zoomFactor As Double
    zoomFactor = ActivePresentation.SlideShowWindow.View.zoom / 100

    Dim hndDC&
    hndDC = GetDC(0)
    Dim deviceCapsX As Double
    deviceCapsX = GetDeviceCaps(hndDC, 88) / 72 ' pixels per pt horizontal (1 pt = 1/72')
    Dim deviceCapsY As Double
    deviceCapsY = GetDeviceCaps(hndDC, 90) / 72 ' pixels per pt vertical (1 pt = 1/72')

    With TransformShape
        ' calculate:
        .topLeft.x = osh.Left * deviceCapsX * zoomFactor
        .topLeft.y = osh.Top * deviceCapsY * zoomFactor
        .bottomRight.x = (osh.Left + osh.width) * deviceCapsX * zoomFactor
        .bottomRight.y = (osh.Top + osh.height) * deviceCapsY * zoomFactor
        ' translate:
        Dim lngStatus As Long
        lngStatus = ClientToScreen(hndDC, .topLeft)
        lngStatus = ClientToScreen(hndDC, .bottomRight)
    End With

    ReleaseDC 0, hndDC
End Function

...
Dim shapeAsRect As Rectangle
shapeAsRect = TransformShape(someSape)

Dim pointerPos As POINTAPI
Dim lngStatus As Long
lngStatus = GetCursorPos(pointerPos)

If ((pointerPos.x <= shapeAsRect.topLeft.x) Or (pointerPos.x >= shapeAsRect.bottomRight.x) Or _
    (pointerPos.y <= shapeAsRect.topLeft.y) Or (pointerPos.y >= shapeAsRect.bottomRight.y)) Then
    ' outside:
    ...
Else ' inside
    ...
End If
...

Answer 2

Shape 的坐标（.Left、.Top、.Width 和 .Height）以一些“文档单位”给出（不知道具体是什么单位）。

积分。 72 磅/英寸。

Sub TryThis()
    Dim osh As Shape
    Set osh = ActiveWindow.Selection.ShapeRange(1)
    With ActiveWindow
        Debug.Print .PointsToScreenPixelsX(.Left)
        Debug.Print .PointsToScreenPixelsY(.Top)
    End With
End Sub