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

shine123

目前代码只能打开当前文件夹下ppt，Presentations.ApplyTheme DZ母版提示出错
Sub 批量修改母版()
Application.ScreenUpdating = False
DZ母版 = "C:UsersAdministratorAppDataRoamingMicrosoftTemplatesDocument 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指定母版
批量修改ppt母版.rar (78.26 KB, 下载次数: 12)

2017-7-16 09:20 上传

点击文件名下载附件

cnshijun

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

zhongwhy

搞定了，不是很完美，但是还是结帖~~~
Sub 批量修改母版()
    Application.ScreenUpdating = False
    DZ母版 = "C:UsersAdministratorAppDataRoamingMicrosoftTemplatesDocument 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

lqq584520

PPT学习论坛，找到组织了！