PPT 批量插入图片代码

gareth

想将文件夹内的图片都插入PPT内，但没有实现，原因是必须要新建100张空白的PPT才能插入，有办法可以实现么？求老师指点。

Sub 插入相册()
Dim j As Integer
For j = 1 To 100

ActivePresentation.Slides(j).Select
With ActiveWindow.Selection.SlideRange
.FollowMasterBackground = msoFalse
.Background.Fill.UserPicture "C:\Users\Administrator\Downloads\ppt\改好\相册\" & j & ".jpg"
End With
Next
End Sub

Yalishanda30

附件供参考

gareth

Yalishanda30 发表于 2020-10-18 18:27
附件供参考

非常感谢老师，可以导入，但还有些问题，就是图片无法与幻灯片一样大小。

gareth

     Dim Width As Single, Height As Single
     With ActivePresentation.PageSetup
     
        Width = .SlideWidth: Height = .SlideHeight
     End With
     Filewidth = (Width)
     Fileheight = (Height)

Yalishanda30

gareth 发表于 2020-10-18 19:22
非常感谢老师，可以导入，但还有些问题，就是图片无法与幻灯片一样大小。

自己调吧我不知道你的ppt分辨率和图片分辨率
Set Shp = oSlide.Shapes.AddPicture(sPath & filearr(i), msoFalse, msoTrue, 0, 0, 204, 120)

gareth

Yalishanda30 发表于 2020-10-18 18:27
附件供参考

非常感谢，可以了！

Yalishanda30

gareth 发表于 2020-10-18 19:28
非常感谢，可以了！

满意就送个花

gareth

Yalishanda30 发表于 2020-10-18 19:28
满意就送个花

再请教一下老师呀，如何用VBA清空所有母版，更换一个新的母版呢

Yalishanda30

gareth 发表于 2020-10-18 19:33
再请教一下老师呀，如何用VBA清空所有母版，更换一个新的母版呢

附件供参考

gareth

Yalishanda30 发表于 2020-10-18 19:47
附件供参考

老师，有个问题，导入的图不是按编号，全打乱了，例如，我的图是1.jpg~21.jpg，现在导入后不是这个顺序。
Sub 插入相册()


     Dim Width As Single, Height As Single
     With ActivePresentation.PageSetup
     
        Width = .SlideWidth: Height = .SlideHeight
     End With
     Filewidth = (Width)
     Fileheight = (Height)
Call del
Dim oPPT As Presentation
Dim oSlide As Slide
Dim oCL As CustomLayout
Dim Shp As Shape
Dim myFile
Dim filearr()
Set oPPT = PowerPoint.ActivePresentation
'spath = PowerPoint.ActivePresentation.path & "\pic\"
spath = "C:\Users\Administrator\Downloads\ppt\改好\相册\"

myFile = Dir(spath & "*.jpg")

Do While myFile <> ""
    ReDim Preserve filearr(i)
    filearr(i) = myFile
    i = i + 1
    myFile = Dir
Loop

With oPPT
    For i = 0 To UBound(filearr)
        Set oCL = .Slides(1).CustomLayout
        Set oSlide = .Slides.AddSlide(i + 2, oCL)
        Set Shp = oSlide.Shapes.AddPicture(spath & filearr(i), msoFalse, msoTrue, 0, 0, Filewidth, Fileheight)
    Next
End With
End Sub