vba PowerPoint 2010 打开多个文件，复制模块和用户表单，另存为.pptm

Question

标题说得差不多了。

我需要在一个目录中递归地打开所有的 PowerPoint 文件(完成)。

我需要从已经打开的文件中复制用户表单和模块。

我需要将原始目录中的所有 PowerPoint 文件重新保存为启用宏的 PowerPoint 文档。

积分 如何确保所有文件都具有与原始文件相同的母版幻灯片，并且在母版更改时更新幻灯片 .

这是打开文件的代码。有用。

Sub OpenAllFiles()

Dim colFiles As New Collection
Dim vFile As Variant
RecursiveDir colFiles, "C:\Users\Debra\Dropbox\School\Mathematics\Notes", "*.pptx", True
For Each vFile In colFiles    
        Presentations.Open (vFile)
Next vFile
End Sub

Answer 1

您提出的问题(奖金前)

这段代码

打开 strDir 下的所有文件即 *c:\temp*

从当前 PPT 文件中导出一个模块 Module1 和一个用户窗体 UserForm

将这些文件保存在 strDir 下作为 pptm 文件

删除原pptx文件

代码

Sub OpenAllFiles()
Dim ppPres As Presentation
Dim fName As String
Dim strDir As String
Dim VbComp1
Dim VbComp2
Set VbComp1 = ActivePresentation.VBProject.VBComponents("Module1")
Set VbComp2 = ActivePresentation.VBProject.VBComponents("UserForm1")
strDir = "c:\temp\"
VbComp1.Export strDir & "\mod1.bas"
VbComp2.Export strDir & "\uf1.frm"

fName = Dir(strDir & "\*.pptx")
Do While fName <> vbNullString
Set ppPres = Presentations.Open(strDir & "\" & fName, msoFalse)
With ppPres
.VBProject.VBComponents.Import strDir & "\mod1.bas"
.VBProject.VBComponents.Import strDir & "\uf1.frm"
.SaveAs Replace(ppPres.Name, "pptx", "pptm"), ppSaveAsOpenXMLShowMacroEnabled
.Close
'remove original pptx file
Kill Dir(strDir & "\*.pptx")
fName = Dir
End With
Loop
End Sub