MS PowerPoint: how to convert a shape's position and size into screen coordinates?

问题

I wrote me a little VBA Macro for PowerPoint (2010) that opens a popup with explanations when hovering over some Shape. This works fine. Alas, there is no event that is triggered when leaving the area again and so I now want to extend the code such that it monitors the area of the popup and when the pointer leaves that area it removes the popup again.

But now I ran into some stupid problem: the coordinates of the Shape (.Left, .Top, .Width, and .Height) are given in some "document units" (don't know exactly what unit this is in). The pointer coordinates, however, are obviously in screen pixels. To be able to reasonably compare the two to calculate whether the pointer is inside or outside I need to first convert the Shape's dimensions into screen pixels.

I googled around a lot, but while I found several at first promising code snippets, none of these worked (as most were for Excel and PowerPoint obviously has a different document model).

Could some kind soul give me a hint or some reference how to convert a Shape's dimension into screen pixels (i.e. taking scaling, window position, zoom-factor etc. into account).

回答1:

In case anyone's interested - here is my solution after LOTS of further googling:

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
...

回答2:

the coordinates of the Shape (.Left, .Top, .Width, and .Height) are given in some "document units" (don't know exactly what unit this is in).

Points. 72 points to the inch.

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

来源：https://stackoverflow.com/questions/14635383/ms-powerpoint-how-to-convert-a-shapes-position-and-size-into-screen-coordinate

标签

powerpoint

shape

pixels