MS PowerPoint: how to convert the position and size of a shape to screen coordinates?
I wrote me a small VBA macro for PowerPoint (2010) that opens a pop-up with explanations when hovering over some shape. This works great. Alas, there is no event that fires when exiting the area again, and so now I want to extend the code so that it controls the area of the popup, and when the pointer leaves that area, it removes the popup again.
But now I am faced with some silly problem: the coordinates of the Shape (.Left, .Top, .Width and .Height) are given in some "document units" (not sure which unit is exactly). However, the coordinates of the pointer are obviously in screen pixels. In order to be able to intelligently compare the two, in order to calculate whether the pointer is inside or outside, I need to first convert the dimensions of the Shape to screen pixels.
I googled a lot, but while I found the first few promising snippets of code, none of them worked (as most of them for Excel and PowerPoint obviously have a different document model).
Can some soul give me a hint or some reference on how to convert the shape dimension to screen pixels (i.e. account for scaling, window position, scaling factor, etc.).
M.
source to share
In case anyone is interested - here is my solution after several further searches:
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
...
source to share
Shape coordinates (.Left, .Top, .Width and .Height) are given in some "document units" (I don't know exactly in which cell).
Points. 72 indicates an 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
source to share