Powerpoint VBA 插入图像并更改大小

Question

我认为这可以解决许多人将图像从一个目录中繁琐地粘贴到 powerpoint 然后调整大小的问题。

我的问题是我在一个目录中有 16 张图片，每个月都需要更新，而且一张一张的更新速度很慢。任务是：

1. 打开目录
2. 打开第一张图片
3. 将图片粘贴到PowerPoint中
4. 将图片重新定位到左上角
5. 将图像大小调整为高 550 x 宽 960（填满 A4 页面）
6. 将图像发送到后面
7. 移至下一张幻灯片
8. 重复第二张图片
9. 继续直到目录中没有更多图像

目录是（例如）“C:\Users\xxxxxx\Documents\Work\Procurement Project\Slides”

第一个图像名称是（例如）“01 摘要”，第二个是“02 客户合同”等

我认为我需要一个 str 和一个路径以及一个表，以便 str 添加到 path 以使用 i 和 i + 1 等创建每个新路径

我想我需要一些有点像这样的代码：

Sub Picture_size_and_position()

Dim oShape As Shape
Dim oPresentation As Presentation
Dim oSlide As Slide
Dim oSelection As Selection

    ActiveWindow.View.GotoSlide oSlide.SlideIndex

  With ActiveWindow.Selection.ShapeRange
    .LockAspectRatio = msoFalse
    .Height = 550
    .Width = 960
    .Left = 0
    .Top = 0
  End With

End Sub

然后我确定我需要一个循环函数来重复此操作，直到使用 i 和 j 的某种组合在目录中没有任何内容...但是整个代码超出了我的范围，非常令人沮丧。

有人可以提供一些建议吗？非常感谢！

谢谢！

Answer 1

Sub ImportABunch()

Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape

' Edit these to suit:
strPath = "C:\Users\username\"
strFileSpec = "*.png"

strTemp = Dir(strPath & strFileSpec)

i = 1

Do While strTemp <> ""
    Set oSld = ActivePresentation.Slides(i)
    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=960, _
    Height:=550)

    i = i + 1


    With oPic
        .LockAspectRatio = msoFalse
        .ZOrder msoSendToBack
    End With

' Or (with thanks to David Marcovitz) make the picture as big as possible on the slide
' without changing the proportions
' Leave the above commented out, uncomment this instead:
'   With oPic
'     If 3 * .width > 4 * .height Then
'         .width = ActivePresentation.PageSetup.Slidewidth
'         .Top = 0.5 * (ActivePresentation.PageSetup.Slideheight - .height)
'     Else
'       .height = ActivePresentation.PageSetup.Slideheight
'         .Left = 0.5 * (ActivePresentation.PageSetup.Slidewidth - .width)
'     End If
'   End With

' Optionally, add the full path of the picture to the image as a tag:
'With oPic
'  .Tags.Add "OriginalPath", strPath & strTemp
'End With

    ' Get the next file that meets the spec and go round again
    strTemp = Dir
Loop

End Sub

感谢http://www.pptfaq.com/index.html - 很棒的小网站！

Answer 2

有一个想法来自动化它/或手动启动一个新的启用宏的 PowerPoint 模板文件。要在文件打开时自动执行宏，请添加 customUI：onLoad="ImagesToPowerPoint"。搜索“CustomUI Editor”。

注意我还没有完全测试自动化部分。

Option Explicit

Sub ImagesToPowerPoint()
    Const FileType As String = "*.png"
    Dim sSaveFilePath As String, sSaveFileName As String, sImagesFolder As String
    Dim oLayout As CustomLayout, oSlide As Slide, i As Long, sFile As String

    sImagesFolder = Environ("USERPROFILE") & "\Documents\Work\Procurement Project\Slides\"
    ' Prepare auto save PowerPoint file name
    sSaveFilePath = Environ("USERPROFILE") & "\Documents\Work\PowerPoints\"
    sSaveFileName = Format(Now, "yyyy_mmdd") & "_Procurement.pptx"

    With ActivePresentation
        ' Use the first layout for all new slides
        Set oLayout = .SlideMaster.CustomLayouts(1)
        ' Start processing all files in the folder
        sFile = Dir(sImagesFolder & FileType)
        Do Until sFile = ""
            ' Add new slide
            Set oSlide = .Slides.AddSlide(.Slides.Count, oLayout)
            ' Delete all the shapes from that layout
            For i = oSlide.Shapes.Count To 1 Step -1
                oSlide.Shapes(i).Delete
            Next
            ' Add the image to slide
            With oSlide.Shapes.AddPicture(sImagesFolder & sFile, msoFalse, msoTrue, 0, 0, oLayout.Width, oLayout.Height)
                .LockAspectRatio = msoFalse
                .AlternativeText = Now & " | " & sImagesFolder & sFile
            End With
            sFile = Dir
        Loop
        .SaveAs sSaveFilePath & sSaveFileName
    End With
    Presentations(sSaveFileName).Close
    If Presentations.Count = 0 Then Application.Quit
End Sub