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

shenjianrong163

实现功能：
        将文档“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, 下载次数: 34)

2020-1-21 11:39 上传

点击文件名下载附件
导出不成功

lss001

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

shenjianrong163

lss001 发表于 2020-2-28 20:32
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal s As Long)
Sub CopyVBComponents() '复制窗体 ...

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

shenjianrong163

lss001 发表于 2020-2-28 20:32
Sub CopyVBComponents()
    Dim f$, p$, s$, vs, ppt, ppts
    p = ActivePresentation.Path & "\"

老师好，您有空时请帮忙看看这个帖子，谢谢：
https://club.excelhome.net/thread-1618676-1-1.html