VBA 将形状粘贴到点的 Powerpoint 宏
VBA Powerpoint macro to paste Shape at point
我正在尝试编写一个在点位置粘贴形状的宏，而不是将其粘贴到复制对象旁边的默认 ppt 行为。
我为 Get_Cursor_Pos 宏分配了一个键盘快捷键，用于保存当前点位置，然后我尝试使用粘贴宏将其粘贴。
但是，后者将其粘贴到与保存的光标位置不同的位置。我怀疑这是由于两个宏中使用了不同的定位单元。我该如何解决这个问题？
' 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
IIRC, GetCursorPos returns 相对于 Windows 屏幕左上角的光标位置，与当前应用程序无关，单位是（？）缇（？）......不确定。 PowerPoint 以点（1/72 英寸）为单位工作。
这可能会有用。 PointsToScreenPixelsX 和 Y return 从 Windows 屏幕的左上角到 PPT 幻灯片上指定位置的偏移量（以像素为单位）。在本例中，我使用了 0，因此您将获得幻灯片左上角的位置（请注意，不是 PPT window）。如果整个 PPT Window 从屏幕的左侧和顶部滑出，直到只显示当前幻灯片的左上角，这将是 return 0。如果你再放大，它会 return 负数；即使您看不到整张幻灯片，它也在那里，而且左上角在负陆地的某个地方。 ;-)
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
正如 Steve 所说，PointsToScreenPixelX(0) 和 PointsToScreenPixelY(0) 属性将给出 slide/normal 视图中幻灯片左上边缘的屏幕坐标。如果您包含下面的代码，那么它会将形状定位在您存储的任何光标位置。
请注意，此代码段适用于 window 的缩放级别 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
我正在尝试编写一个在点位置粘贴形状的宏，而不是将其粘贴到复制对象旁边的默认 ppt 行为。
我为 Get_Cursor_Pos 宏分配了一个键盘快捷键，用于保存当前点位置，然后我尝试使用粘贴宏将其粘贴。
但是，后者将其粘贴到与保存的光标位置不同的位置。我怀疑这是由于两个宏中使用了不同的定位单元。我该如何解决这个问题？
' 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
IIRC, GetCursorPos returns 相对于 Windows 屏幕左上角的光标位置，与当前应用程序无关，单位是（？）缇（？）......不确定。 PowerPoint 以点（1/72 英寸）为单位工作。
这可能会有用。 PointsToScreenPixelsX 和 Y return 从 Windows 屏幕的左上角到 PPT 幻灯片上指定位置的偏移量（以像素为单位）。在本例中，我使用了 0，因此您将获得幻灯片左上角的位置（请注意，不是 PPT window）。如果整个 PPT Window 从屏幕的左侧和顶部滑出，直到只显示当前幻灯片的左上角，这将是 return 0。如果你再放大，它会 return 负数；即使您看不到整张幻灯片，它也在那里，而且左上角在负陆地的某个地方。 ;-)
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
正如 Steve 所说，PointsToScreenPixelX(0) 和 PointsToScreenPixelY(0) 属性将给出 slide/normal 视图中幻灯片左上边缘的屏幕坐标。如果您包含下面的代码，那么它会将形状定位在您存储的任何光标位置。
请注意，此代码段适用于 window 的缩放级别 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