excel vba 如何批量修改当前文件夹下ppt母版-

Mr.蟋蟀

目前代码只能打开当前文件夹下ppt，Presentations.ApplyTheme DZ母版提示出错
Sub 批量修改母版()
    Application.ScreenUpdating = False
    DZ母版 = "C:\Users\Administrator\AppData\Roaming\Microsoft\Templates\Document Themes\模板提供者-16-12-14.thmx" '母版地址
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.GetFolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    ActiveSheet.UsedRange.ClearContents
    a = 1
    For Each f In ff.Files
        If f Like "*.pptx" Then
          MsgBox "发现" & f.Name
        Cells(a, 1) = f.Name '相对路径名
        Cells(a, 2) = f '全路径名
    Set Myppt = CreateObject("PowerPoint.Application")
    Myppt.Visible = True
    Myppt.Presentations.Open f
                                                               '为幻灯片选择母版
        a = a + 1
        End If

    Next f
    Application.ScreenUpdating = True
End Sub
不知哪句代码可以将打开的ppt指定母版

Mr.蟋蟀

顶一下~~~~~~~~~~~~~~

Mr.蟋蟀

搞定了，不是很完美，但是还是结帖~~~
Sub 批量修改母版()
    Application.ScreenUpdating = False
    DZ母版 = "C:\Users\Administrator\AppData\Roaming\Microsoft\Templates\Document Themes\模板提供者-16-12-14.thmx" '母版地址
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.GetFolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    ActiveSheet.UsedRange.ClearContents
    a = 1
    For Each f In ff.Files
        If f Like "*.pptx" Then
'          MsgBox "发现" & f.Name
    Set Myppt = CreateObject("PowerPoint.Application")
    Myppt.Visible = True
    Set newppt = Myppt.Presentations.Open(Filename:=f)
          newppt.ApplyTemplate Filename:=DZ母版                                            '为幻灯片选择母版
          newppt.Save
          newppt.Close
          Set newppt = Nothing
          Set Myppt = Nothing
        Cells(a, 1) = f.Name '相对路径名
        Cells(a, 2) = f '全路径名
        
        a = a + 1
        End If

    Next f
   
    Application.ScreenUpdating = True
End Sub

whx0910

感谢了  不错 哦   多谢

whx0910

学习了 不错

前进者

做好标记，今后学习！