excel vba 如何批量修改当前文件夹下ppt母版-
目前代码只能打开当前文件夹下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指定母版 顶一下~~~~~~~~~~~~~~ 搞定了，不是很完美，但是还是结帖~~~
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
页:
[1]