MS PowerPoint:如何将形状的位置和大小转换为屏幕坐标? [英] MS PowerPoint: how to convert a shape's position and size into screen coordinates?

问题描述

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

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.

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

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.

我在谷歌上搜索了很多，但虽然一开始我发现了几个很有希望的代码片段，但这些都没有奏效(因为大多数用于 Excel，而 PowerPoint 显然有不同的文档模型).

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

M.

推荐答案

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

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

这篇关于MS PowerPoint:如何将形状的位置和大小转换为屏幕坐标?的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！