Powerpoint VBA插入图像并更改大小

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

我的问题是，我有16个图像都在一个目录中，每个月都需要更新，一个接一个的更新速度非常慢。任务是：

开放目录

打开第一个图像

将图像粘贴到powerpoint中

将图像重新定位到左上角

将图像调整为高度550，宽度960（填充A4页）

将图像发送回

转到下一张幻灯片

重复第二个图像

继续，直到目录中不再有图像

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

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

我想我需要一个str和一个path，以及一个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的组合在目录中什么都没有了……但是整个代码远远超出了我的理解范围，非常令人沮丧

有人能给点建议吗？非常感谢

谢谢大家!

Sub-importBunch（）
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

将strTemp设置为字符串
将strPath设置为字符串
作为字符串的Dim strFileSpec
将oSld设置为幻灯片
像形状一样暗淡
'编辑这些内容以适合：
strPath=“C:\Users\username\”
strFileSpec=“*.png”
strTemp=Dir（strPath和strFileSpec）
i=1
当strTemp“”时执行
设置oSld=ActivePresentation.Slides（i）
设置oPic=oSld.Shapes.AddPicture（文件名：=strPath&strTemp_
LinkToFile:=msoFalse_
SaveWithDocument:=msoTrue_
左：=0_
顶部：=0_
宽度：=960_
高度：=550）
i=i+1
与oPic
.LockAspectRatio=msoFalse
ZOrder msoSendToBack先生
以
或者（感谢大卫·马科维茨）在幻灯片上尽可能放大图片
"不改变比例,
'保留上述注释，改为取消注释：
“用oPic
'如果3*宽度>4*高度，则
'.width=ActivePresentation.PageSetup.Slidewidth
'.Top=0.5*（ActivePresentation.PageSetup.SlidehHeight-.height）
”“否则呢
'.height=ActivePresentation.PageSetup.SlideHight
'.Left=0.5*（ActivePresentation.PageSetup.Slidewidth-.width）
"完"
"以
'可选地，将图片的完整路径作为标记添加到图像中：
“用oPic
'.Tags.Add“OriginalPath”、strPath和strTemp
"以
'获取下一个符合规范的文件，然后再次循环
strTemp=Dir
环
端接头

---

信用-伟大的小网站

有一个想法，可以将其自动化/或手动启动新的启用宏的PowerPoint模板文件。要在文件打开时自动执行宏，请添加customUI:

onLoad=“ImagesToPowerPoint”

。在“CustomUI编辑器”中搜索它

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

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

---

好吧，我自己用谷歌搜索解决了这个问题！如果有人感兴趣，以下是代码：