Question

我正在创建一个脚本，将来自各种其他.pptx文件的幻灯片复制到Master PowerPoint中，但是如果其中一个文件是由另一个用户同时打开宏，则会收到80004005错误。我的脚本如下：

Public Sub Update()

Dim PPTApp As Object
Dim PPT As Object
Dim MasterPPT As Presentation
Dim Total As Integer
Dim FSO As New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim File As Scripting.File

Set MasterPPT = Presentations("Combined Staff Agenda Template.pptm")
Total = MasterPPT.Slides.Count

Set PPTApp = CreateObject("PowerPoint.Application")

' Sets the first ComboBox destination folder
Set Folder = FSO.GetFolder("O:\org\acle\Common\PE_SHARE\Technical Staff Meeting Agendas\Individual Slides\" & Order_UserForm.comboFirst.Value)

For Each SubFolder In Folder.SubFolders
    For Each File In SubFolder.Files

    ' Copies and pastes all slides for each file
    Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
    PPT.Slides.Range.Copy
    MasterPPT.Slides.Paste (Total)

    PPT.Close

    Total = MasterPPT.Slides.Count

    Next File
Next SubFolder

对于另外两个文件夹，For Each循环重复两次，然后子例程结束。文件夹系统的组织如下：父目录（＆＃34;技术人员会议议程＆＃34;）＆gt; ＆＃34;个人幻灯片＆＃34; ＆GT;三（3）个部门文件夹＆gt;单个用户文件夹，每个文件夹中都有一个.pptx文件。访问File.Path的任何解决方法（如果已经打开）

Answer 1

完全未经测试，但让我们尝试这样的事情（假设您在Presentations.Open上收到错误。我在此方法调用周围添加了一个错误处理块，并根据文档（here）看起来.Open方法的Untitled参数等同于创建文件的副本。

如果这不起作用，请告诉我。我可以修改以显式创建和打开该文件的副本，然后打开它。

更新由于Untitled属性不起作用，让我们尝试显式创建该文件的副本。我没有包括任何＆＃34;清理＆＃34;用于删除复制版本的代码。

Public Sub Update()

Dim PPTApp As Object
Dim PPT As Object
Dim MasterPPT As Presentation
Dim Total As Integer
Dim FSO As New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim File As Scripting.File

Set MasterPPT = Presentations("Combined Staff Agenda Template.pptm")
Total = MasterPPT.Slides.Count

Set PPTApp = CreateObject("PowerPoint.Application")

' Sets the first ComboBox destination folder
Set Folder = FSO.GetFolder("O:\org\acle\Common\PE_SHARE\Technical Staff Meeting Agendas\Individual Slides\" & Order_UserForm.comboFirst.Value)

For Each SubFolder In Folder.SubFolders
    For Each File In SubFolder.Files

    ' Copies and pastes all slides for each file
    On Error GoTo FileInUseError
    Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
    On Error GoTo 0
    PPT.Slides.Range.Copy
    MasterPPT.Slides.Paste (Total)

    PPT.Close

    Total = MasterPPT.Slides.Count

    Next File
Next SubFolder

'## It's important to put this before your error-handling block:
Exit Sub

'## Error handling:
Err.Clear

'## First attempt, did not work as expected
'Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, Untitled:=msoTrue, WithWindow:=msoFalse)

 '## Second attempt. You will need to add some logic to remove these files or do it manually.
Dim copyPath as String
copyPath = Replace(File.Path, File.Name, "Copy of " & File.Name)
FSO.CopyFile File.Path, copyPath, True
Set PPT = PPTApp.Presentations.Open(copyPath)


Resume Next

End Sub

更新2

你可以尝试的其他事情（不太可能有效，但你应该尝试它们）：

我注意到这段代码是在PowerPoint中执行的，所以有一件事没有意义：Set PPTApp = CreateObject("PowerPoint.Application")。您已经在运行PPT实例，并且只运行一个PPT实例（与可以有多个实例的Excel不同）。所以完全摆脱那条线。

'Set PPTApp = CreateObject("PowerPoint.Application")

然后你也可以摆脱变量PPTApp。我注意到您为PowerPoint对象变量使用早期绑定和后期绑定的组合。这不是真的有意义，虽然我不希望这会导致任何错误，但你永远不会知道。

'Dim PPTApp as Object 'PowerPoint.Application  '## This is unnecessary!!
Dim PPT as Presentation
Dim MasterPPT as Presentation

如果所有其他方法都失败了，请打开新文件WithWindow=msoTrue并使用F8逐行逐步执行代码...

更新3

虽然我无法测试另一个用户锁定/正在使用的文件，但我能够测试如果我有一个正在使用的文件会发生什么自己。我使用以下代码并确定Files迭代最终将遇到文件的lock / tmp版本，以＆＃34;〜＆＃34;开头。波浪形的角色。这些通常是隐藏的文件，但FSO正在迭代中将它们拾起。

除此之外，如果文件不是有效的PPT文件类型（PPT，PPTX，PPTM，XML等），我会遇到类似的错误。如果有错误，我使用以下代码在立即窗口中打印错误日志（并通知MsgBox提示）。

Sub Test()
Dim MasterPPT As Presentation
Dim PPT As Presentation
Dim Total As Integer
Dim FSO As Object
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object
Dim errMsg$
Dim copyPath$

Set MasterPPT = ActivePresentation '## Modify as needed.

Total = MasterPPT.Slides.Count

Set FSO = CreateObject("Scripting.FileSystemObject")

' Sets the first ComboBox destination folder // MODIFY AS NEEDED
Set Folder = FSO.GetFolder("C:\Users\david_zemens\Desktop\CHARTING STANDARDS")

For Each SubFolder In Folder.SubFolders
    For Each File In SubFolder.Files
        ' Copies and pastes all slides for each file
        On Error GoTo FileInUseError:
        ' Make sure it's a PPT file:
        If File.Type Like "Microsoft PowerPoint*" Then
10:
            Set PPT = Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
20:
           PPT.Slides.Range.Copy
30:
            MasterPPT.Slides.Paste (Total)

            PPT.Close

        End If
        On Error GoTo 0

    Total = MasterPPT.Slides.Count
NextFile:
    Next File
Next SubFolder

'## It's important to put this before your error-handling block:
Set FSO = Nothing
Set Folder = Nothing
Set SubFolder = Nothing
Set File = Nothing

Exit Sub

FileInUseError:
'## Error handling:
'## Display information about the error
errMsg = "Error No.: " & Err.Number & vbCrLf
errMsg = errMsg & "Description: " & Err.Description & vbCrLf
errMsg = errMsg & "At line #: " & Erl & vbCrLf
errMsg = errMsg & "File.Name: " & File.Name
Debug.Print errMsg & vbCrLf
MsgBox errMsg, vbInformation, "Error!"
Err.Clear
Resume NextFile

End Sub

VBA - 自动PowerPoint不会打开另一个用户正在使用的.pptx文件

1 个答案: