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

Question

标题几乎说。

1. 我需要在目录（完成）中递归打开所有PowerPoint文件。
2. 我需要从已经打开的文件中复制Userform和模块。
3. 我需要将原始目录中的所有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 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

Answer 2

如果你得到的参考Presentation对象从返回Presentations.Open您可以直接操作打开的演示文稿。 否则，打开它们后必须遍历Presentations对象。 当您有Presentation对象时，您可以看到用于该Presentation的SlideMaster 。 至于复制VBA代码，您可以尝试http://www.cpearson.com/excel/vbe.aspx或http://www.mrexcel.com/articles/copy-vb​​a-module.php之类的东西。

例：

Option Explicit

Sub Test()
    'Declare variables
    Dim oPres As Presentation
    Dim oMaster As Master

    'Get presentation
    Set oPres = Presentations.Open("Gud vilken härlig powerpoint.pptx")

    'Get master
    Set oMaster = oPres.SlideMaster

    'Do something
    Debug.Print oPres.Name
    Debug.Print oMaster.Name

    'Save as macro-ppt
    Call oPres.SaveAs("NEW-FILE-NAME.pptm", ppSaveAsOpenXMLPresentationMacroEnabled)

    'Clean up
    Set oMaster = Nothing
    Set oPres = Nothing

End Sub