VBA导出模块、窗体、类模块给另一个PPT不成功

viezen

实现功能：
将文档“VBA导出模块、窗体、类模块给另一个PPT.ppt”中的模块、窗体、类模块等导出给自动打开的文档“新建演示文稿.ppt”。
出现的问题：
1.如果“新建演示文稿.ppt”中没有模块，则导入是成功的。
2.如果“新建演示文稿.ppt”中已经有模块，这个就会变成复制“新建演示文稿.ppt”中的模块了。例如： “新建演示文稿.ppt”中已经有“模块1”，运行后多了一个“模块11”，原来的幻灯片中的模块、窗体等都没有复制过去。怎样解决这个问题?
“VBA导出模块、窗体、类模块给另一个PPT.ppt”中的代码如下：
Sub CopyVBComponents() '复制窗体、模块、类模块给另一个PPT
Dim f$, p$, d, ppt_name
Set d = CreateObject("Scripting.Dictionary")
p = ActivePresentation.Path & ""
f = Dir(p & "*.ppt")
Do While Len(f)
If f  ActivePresentation.Name Then '本文件除外
d(f) = ""
End If
f = Dir
Loop
ppt_name = d.keys '将字典的数据放入数组
If (UBound(ppt_name) < 0) Then
MsgBox "当前目录下没有其它的PPT", 48, "警告"
Exit Sub
Else
For i = 0 To UBound(ppt_name)
Set pptInput = Presentations.Open(p & "" & ppt_name(i), ReadOnly:=msoFalse)
'================= 以下是复制窗体、模块、类模块
Dim vbc As Object
Application.VBE.MainWindow.SetFocus
For Each vbc In Application.VBE.ActiveVBProject.VBComponents
vbc.Export p & "" & vbc.Name '导出
pptInput.VBProject.VBComponents.Import p & "" & vbc.Name '导入
Kill p & "" & vbc.Name '删除导出
Next
Presentations(p & "" & ppt_name(i)).Save
Presentations(p & "" & ppt_name(i)).Close
Next i
End If
End Sub
VBA导出模块、窗体、类模块给另一个PPT.rar (75.17 KB, 下载次数: 14)

2020-8-15 07:49 上传

点击文件名下载附件

jcarry

Sub CopyVBComponents()
    Dim f$, p$, s$, vs, ppt, ppts
    p = ActivePresentation.Path & &quot;&quot;
    f = Dir(p & &quot;*.ppt&quot;)
    On Error Resume Next
    Do While Len(f)
        If f <> ActivePresentation.Name Then '本文件除外
            Set ppt = ActivePresentation '务必先获取当前ppt/后打开ppts
            Set ppts = Presentations.Open(p & f, ReadOnly:=0)
            For Each vs In ppt.VBProject.VBComponents
                s = p & vs.Name: vs.Export s '导出
                ppts.VBProject.VBComponents.Import s  '导入
                Kill s: Kill s & &quot;.frx&quot; '删除s以及s.frx
            Next
            Presentations(p & f).Save
            Presentations(p & f).Close
        End If
        f = Dir
    Loop
End Sub

zhu003

谢谢，总算明白问题的根本原因！