用 VBA 在 PPT 中批量插入图片

用户6021899

发布于 2023-08-09 13:32:12

5731

发布于 2023-08-09 13:32:12

文章被收录于专栏：Python编程 pyqt matplotlibPython编程 pyqt matplotlib

网上用 VBA 操作 EXCEL的示例很多，但用 VBA 操作 PPT 的示例很少，而且通常有不少错误或者版本老旧的地方。

下面是我最近写的在 PPT 中批量插入图片的代码，供大家参考。

插入图片前的PPT页面：

VBA 代码：

Sub insert_images()
    ' 定义变量
    Dim pptApp As Object, pptPres As Object, slide As Object, shape As Object
    Dim workingpath  As String, cell_height As Integer, cell_width As Integer, x As Integer, y As Integer
    Dim fso As Object, folder As Object, subfolder As Object, file As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    ' 创建 PowerPoint Application 对象
    Set pptApp = GetObject(, "PowerPoint.Application")


    'If pptApp Is Nothing Then

        'Set pptApp = CreateObject("PowerPoint.Application")
    'End If


    On Error GoTo 0


    'ActivePresentation.Slides.Count '获取当前演示文稿中的幻灯片数量


    ' 使 PowerPoint Application 不可见


    'pptApp.Visible = False


    workingpath = ActivePresentation.Path '获取当前PPT的路径


    ' 在当前演示文稿中插入图片
    Dim slideIndex As Integer
    slideIndex = ActiveWindow.View.slide.slideIndex '获取当前幻灯片的索引号  ' 幻灯片编号从1开始


    Set slide = ActivePresentation.Slides(slideIndex) '当前slide ' 幻灯片编号从1开始
    


    workingpath = ActivePresentation.Path
    Debug.Print
    Debug.Print "Current path: " & workingpath
    


    Set folder = fso.GetFolder(workingpath & "\Images") '指定要遍历的文件夹路径
    cell_width = 300
    cell_height = 217
    y = 295
    For Each subfolder In folder.SubFolders
        Debug.Print subfolder.Path '输出路径
        x = 255
        For Each file In subfolder.Files
            Debug.Print "   " & file.Path
                    Set shp = slide.Shapes.AddPicture(FileName:=file.Path, _
            LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
            With shp
                .LockAspectRatio = msoTrue  ' 锁定纵横比
                .Left = x
                .Top = y
                .Height = cell_height - 10
            End With
            x = x + 400
            'Exit For
            
        Next file
        y = y + cell_height
    Next
    
    ' 保存并关闭演示文稿
    ActivePresentation.Save
    '退出 PowerPoint Application
    'pptApp.Quit


    '释放对象


    Set shape = Nothing


    Set slide = Nothing


    Set pptPres = Nothing


    Set pptApp = Nothing


End Sub

运行宏之后的效果：