VBA Powerpoint macro to paste Shape at point - vba

Question

I am trying to write a Macro that pastes a shape at the point position instead of the default ppt behavior which is to paste it next to the copied object.
I assigned a keyboard shortcut to the Get_Cursor_Pos macro which saves the current point position and then I try to paste it with the Paste macro.
However, the latter pastes it in a different position than the saved cursor position. I suspect this is due to different positioning units being used in both macros. How can I fix this issue?
' Access the GetCursorPos function in user32.dll
Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
' Access the GetCursorPos function in user32.dll
Declare Function SetCursorPos Lib "user32" _
(ByVal x As Long, ByVal y As Long) As Long
' GetCursorPos requires a variable declared as a custom data type
' that will hold two integers, one for x value and one for y value
Type POINTAPI
X_Pos As Long
Y_Pos As Long
End Type
' Dimension the variable that will hold the x and y cursor positions
Dim Hold As POINTAPI
' Main routine to dimension variables, retrieve cursor position,
' and display coordinates
Sub Get_Cursor_Pos()
' Place the cursor positions in variable Hold
GetCursorPos Hold
End Sub
Sub Paste()
ActivePresentation.Slides(1).Shapes.Paste
With ActiveWindow.Selection.ShapeRange
.Left = Hold.X_Pos
.Top = Hold.Y_Pos
End With
End Sub
------ EDIT -------
For the sake of helping other people with the same problem here is a solution incorporating Shyam and Steve's answers below. Since PPT doesn't allow you to assign a shortcut key to a macro (unless you use a paid add-in) I had to create an add-in with a toolbar as described here http://www.pptfaq.com/FAQ00031_Create_an_ADD-IN_with_TOOLBARS_that_run_macros.htm.
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Access the GetCursorPos function in user32.dll
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
' GetCursorPos requires a variable declared as a custom data type
' that will hold two integers, one for x value and one for y value
Type POINTAPI
X_Pos As Long
Y_Pos As Long
End Type
' Dimension the variable that will hold the x and y cursor positions
Dim Hold As POINTAPI
Function GetSlideOriginOnScreen(Window As DocumentWindow) As POINTAPI
Dim pt As POINTAPI
With Window
pt.X_Pos = .PointsToScreenPixelsX(0)
pt.Y_Pos = .PointsToScreenPixelsY(0)
End With
GetSlideOriginOnScreen = pt
End Function
Function ConvertPixelToPointX(x As Long) As Single
Const LOGPIXELSX = 88
Const POINTSPERINCH = 72
Dim hDC As Long
Dim sngX As Long
hDC = GetDC(0)
sngX = GetDeviceCaps(hDC, LOGPIXELSX)
Call ReleaseDC(0, hDC)
ConvertPixelToPointX = (x / sngX) * POINTSPERINCH
End Function
Function ConvertPixelToPointY(y As Long) As Single
Const LOGPIXELSY = 90
Const POINTSPERINCH = 72
Dim hDC As Long
Dim sngY As Long
hDC = GetDC(0)
sngY = GetDeviceCaps(hDC, LOGPIXELSY)
Call ReleaseDC(0, hDC)
ConvertPixelToPointY = (y / sngY) * POINTSPERINCH
End Function
Sub Auto_Open()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
' Give the toolbar a name
MyToolbar = "Paste Tools"
On Error Resume Next
' so that it doesn't stop on the next line if the toolbar's already there
' Create the toolbar; PowerPoint will error if it already exists
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, Temporary:=True)
If Err.Number <> 0 Then
' The toolbar's already there, so we have nothing to do
Exit Sub
End If
On Error GoTo ErrorHandler
' Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton
.DescriptionText = "Get cursor position"
'Tooltip text when mouse if placed over button
.Caption = "Get cursor position"
'Text if Text in Icon is chosen
.OnAction = "Button1"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 38
' chooses icon #52 from the available Office icons
End With
' Now add a button to the new toolbar
Set oButton2 = oToolbar.Controls.Add(Type:=msoControlButton)
' And set some of the button's properties
With oButton2
.DescriptionText = "Paste at cursor"
'Tooltip text when mouse if placed over button
.Caption = "Paste at cursor"
'Text if Text in Icon is chosen
.OnAction = "Button2"
'Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
' Button displays as icon, not text or both
.FaceId = 40
' chooses icon #52 from the available Office icons
End With
' Repeat the above for as many more buttons as you need to add
' Be sure to change the .OnAction property at least for each new button
' You can set the toolbar position and visibility here if you like
' By default, it'll be visible when created. Position will be ignored in PPT 2007 and later
oToolbar.Top = 150
oToolbar.Left = 150
oToolbar.Visible = True
NormalExit:
Exit Sub ' so it doesn't go on to run the errorhandler code
ErrorHandler:
'Just in case there is an error
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
Sub Button1()
GetCursorPos Hold
End Sub
Sub Button2()
Dim zoom As Double
zoom = ActiveWindow.View.zoom / 100
With ActivePresentation.Slides(1).Shapes.Paste
.Left = ConvertPixelToPointX((Hold.X_Pos - GetSlideOriginOnScreen(ActiveWindow).X_Pos) / zoom)
.Top = ConvertPixelToPointY((Hold.Y_Pos - GetSlideOriginOnScreen(ActiveWindow).Y_Pos) / zoom)
End With
End Sub

Answer 1

IIRC, GetCursorPos returns the cursor position relative to the upper left of the Windows screen, regardless of the current application, and the units are (?) twips (?) ... not sure. PowerPoint works in points (1/72 of an inch).
This may be useful. PointsToScreenPixelsX and Y return the offset (in pixels) from the upper left of the Windows screen to the place on the PPT Slide specified. In this case, I've used 0, so you'd get the position of the upper left corner of the slide (NOT the PPT window, mind). If the entire PPT Window is slid off the left and top of screen until just the upper left of the current slide is showing, this'll return 0s. If you then zoom in, it'll return negative numbers; even if you can't SEE the entire slide, it's there and the top left corner is off in minus-land somewhere. ;-)
Sub WhereAreWe()
Dim xPixels As Long
Dim yPixels As Long
With ActiveWindow
xPixels = .PointsToScreenPixelsX _
(0)
yPixels = .PointsToScreenPixelsY _
(0)
End With
Debug.Print xPixels & vbTab & yPixels
End Sub

Answer 2

As Steve as said, the PointsToScreenPixelX(0) and PointsToScreenPixelY(0) properties will give the screen co-ordinates of the top-left edge of slide in slide/normal view. If you include the code below then it will position the shape at whatever cursor position you store.
Note that this snippet works at zoom level 100 for the window. For other values, you will have to scale accordingly.
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Function GetSlideOriginOnScreen(Window As DocumentWindow) As POINTAPI
Dim pt As POINTAPI
With Window
pt.X_Pos = .PointsToScreenPixelsX(0)
pt.Y_Pos = .PointsToScreenPixelsY(0)
End With
GetSlideOriginOnScreen = pt
End Function
Function ConvertPixelToPointX(X As Long) As Single
Const LOGPIXELSX = 88
Const POINTSPERINCH = 72
Dim hDC As Long
Dim sngX As Long
hDC = GetDC(0)
sngX = GetDeviceCaps(hDC, LOGPIXELSX)
Call ReleaseDC(0, hDC)
ConvertPixelToPointX = (X / sngX) * POINTSPERINCH
End Function
Function ConvertPixelToPointY(Y As Long) As Single
Const LOGPIXELSY = 90
Const POINTSPERINCH = 72
Dim hDC As Long
Dim sngY As Long
hDC = GetDC(0)
sngY = GetDeviceCaps(hDC, LOGPIXELSY)
Call ReleaseDC(0, hDC)
ConvertPixelToPointY = (Y / sngY) * POINTSPERINCH
End Function
Now change your code to the following call:
Sub Paste()
With ActivePresentation.Slides(1).Shapes.Paste(1)
.Left = ConvertPixelToPointX(Hold.X_Pos - GetSlideOriginOnScreen(ActiveWindow).X_Pos)
.Top = ConvertPixelToPointY(Hold.Y_Pos - GetSlideOriginOnScreen(ActiveWindow).Y_Pos)
End With
End Sub