PowerPoint VBA：复制并粘贴图像、居中对齐并拉伸以适合页面

Question

我正在尝试创建一个命令以在 PowerPoint 中自动导出 PDF。

我有一个命令可以粘贴一张有效的照片。但是，它只是粘贴到屏幕的左上角。

我一直在网上寻找一个脚本来对齐幻灯片的中心并拉伸以适合幻灯片页面。我想录下来，但是PowerPoint好像没有录音功能。

下面是我的复制粘贴脚本。

Sub PastePhoto()
Dim Sld As Slide
'Ensure focus is on slide
Application.ActiveWindow.Panes(2).Activate

Set Sld = Application.ActiveWindow.View.Slide

On Error GoTo NoCopy
    Sld.Shapes.PasteSpecial (ppPasteEnhancedMetafile)
On Error GoTo 0

Exit Sub

NoCopy:
MsgBox "There was nothing copied to paste!"

Answer 1

这应该是将图片插入幻灯片并拉伸图片以适应幻灯片宽度所需的全部内容：

' Get the first slide...
Dim sl As Slide
Set sl = ActivePresentation.Slides(1)

' Insert a picture at (0, 0)...
Dim sh As Shape
Set sh = sl.Shapes.AddPicture("c:\path\to\my.jpg", msoFalse, msoTrue, 0, 0)

' Set the picture's width to that of a slide...
sh.Width = ActivePresentation.PageSetup.SlideWidth

如果您想将其垂直居中：

sh.Top = (ActivePresentation.PageSetup.SlideHeight - sh.Height) / 2

Answer 2

经过一些调整，我弄明白了:)

Sub PastePhoto()

Const ppLayoutBlank = 12

Dim objWorkSheet As Worksheet
Dim objRange As Range
Set objWorkSheet = ThisWorkbook.ActiveSheet

Range("A1:H18").Select
Range("H18").Activate
Selection.Copy

Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True

Set objPresentation = objPPT.Presentations.Add
Set objSlide = objPresentation.Slides.Add(1, 1)

objPresentation.Slides(1).Layout = ppLayoutBlank

' paste as the meta file
objPPT.Windows(1).View.PasteSpecial ppPasteMetafilePicture, msoTrue, , ,         "testlabel"
End Sub

PowerPoint VBA：复制并粘贴图像、居中对齐并拉伸以适合页面

PowerPoint VBA: Copy and paste image, align to center, and stretch to fit page

powerpoint

vba

copy

paste