VBA Powerpoint宏在点处粘贴Shape

Question

我正在尝试编写一个在点位置粘贴形状的宏，而不是将其粘贴到复制对象旁边的默认ppt行为。

我为Get_Cursor_Pos宏分配了一个键盘快捷键，它保存了当前的点位置，然后我尝试用Paste宏粘贴它。

但是，后者将其粘贴到与保存的光标位置不同的位置。我怀疑这是由于两个宏中使用了不同的定位单元。我该如何解决这个问题？

' 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

------编辑-------

为了帮助解决同样问题的其他人，下面是Shyam和Steve的答案。由于PPT不允许您为宏指定快捷键（除非您使用付费加载项），我必须使用工具栏创建加载项，如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返回相对于 Windows 屏幕左上角的光标位置，无论当前应用程序如何，单位都是（？）缇（？）......不确定。 PowerPoint以点（1/72英寸）工作。

这可能很有用。 PointsToScreenPixelsX和Y返回从Windows屏幕左上角到指定的PPT幻灯片上的位置的偏移量（以像素为单位）。在这种情况下，我使用了0，所以你得到了幻灯片左上角的位置（不是PPT窗口，请注意）。如果整个PPT窗口从屏幕的左侧和顶部滑出，直到显示当前幻灯片的左上角，这将返回0。如果你然后放大，它将返回负数;即使你不能看到整个幻灯片，它就在那里，左上角在某个地方的负空间里。 ; - ）

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

正如Steve所说，PointsToScreenPixelX（0）和PointsToScreenPixelY（0）属性将在幻灯片/普通视图中给出幻灯片左上边缘的屏幕坐标。如果您包含下面的代码，那么它会将形状定位在您存储的任何光标位置。

请注意，此代码段适用于窗口的缩放级别100。对于其他值，您必须相应地进行缩放。

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

现在将您的代码更改为以下调用：

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