VBA导出模块、窗体、类模块给另一个PPT不成功
实现功能：将文档“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 fActivePresentation.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
Sub CopyVBComponents()
Dim f$, p$, s$, vs, ppt, ppts
p = ActivePresentation.Path & ""
f = Dir(p & "*.ppt")
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 & ".frx" '删除s以及s.frx
Next
Presentations(p & f).Save
Presentations(p & f).Close
End If
f = Dir
Loop
End Sub 谢谢，总算明白问题的根本原因！
页:
[1]