Question

我给我写了一个用于PowerPoint的小VBA宏（2010），当鼠标悬停在某个Shape上时会弹出一个带有解释的弹出窗口。这很好用。唉，再次离开该区域时没有触发事件，因此我现在想要扩展代码，以便监视弹出区域，当指针离开该区域时，它会再次移除弹出窗口。

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

我搜索了很多内容，但是当我发现几个有希望的代码片段时，这些都没有用（因为大多数用于Excel和PowerPoint显然有不同的文档模型）。

某种灵魂可以给我一个提示或一些参考如何将Shape的尺寸转换为屏幕像素（即考虑缩放，窗口位置，缩放因子等）。

微米。

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

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

2 个答案: