找回密码
 立即注册
搜索

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

2
回复
841
查看
[复制链接]

5

主题

9

帖子

108

幻币

江湖少侠

Rank: 2

积分
172
QQ
2020-8-15 07:49:33 显示全部楼层 |阅读模式
实现功能:
将文档“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)
PPT学习论坛
回复

使用道具 举报

1

主题

9

帖子

25

幻币

江湖少侠

Rank: 2

积分
152
QQ
2020-8-15 11:01:31 显示全部楼层
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
PPT学习论坛
回复 支持 反对

使用道具 举报

2

主题

15

帖子

56

幻币

江湖少侠

Rank: 2

积分
160
QQ
2020-8-15 11:02:02 显示全部楼层
谢谢,总算明白问题的根本原因!
PPT学习论坛
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册