VBA - 自动 PowerPoint 不会打开其他用户正在使用的 .pptx 文件 [英] VBA - Automated PowerPoint won't open .pptx file that is being used by another User

问题描述

我正在创建一个脚本，用于将幻灯片从各种其他 .pptx 文件复制到主 PowerPoint 中，但是如果其中一个文件被另一个用户同时打开，宏执行我会收到 80004005 错误.我的脚本如下:

I am creating a script that copies slides from various other .pptx files into a Master PowerPoint, but if one of the files is opened by another User at the same time the macro executes I receive an 80004005 error. My script is as follows:

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 循环对另外两个文件夹重复两次，然后子程序结束.文件夹系统的组织方式如下:父目录(技术人员会议议程")>个人幻灯片"> 三 (3) 个部门文件夹 > 个人用户文件夹，每个文件夹中都有一个 .pptx 文件.如果 File.Path 已经打开，是否有访问它的解决方法?

The For Each loop is repeated twice for two more folders, and then the sub routine ends. The folder system is organized as follows: Parent Directory ("Technical Staff Meeting Agendas") > "Individual Slides" > Three (3) Department Folders > Individual User Folders with a .pptx file in each. Any workaround for accessing the File.Path if it is already opened?

推荐答案

完全未经测试，但让我们尝试这样的事情(假设您在 Presentations.Open 上遇到错误.我添加了一个错误- 围绕此方法调用的处理块，并基于文档 (here) 看起来 .Open 方法的 Untitled 参数相当于创建文件的副本.

Completely untested, but let's try something like this (assuming you're getting an error on Presentations.Open. I added an error-handling block around this method call, and based on the documentation (here) it looks like the .Open method's Untitled argument is equivalent to creating a copy of the file.

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

If that doesn't work, let me know. I can revise to explicitly create and open a copy of the file and open that, instead.

UPDATE 由于 Untitled 属性不起作用，让我们尝试显式创建文件的副本.我没有包含任何清理"代码来删除复制的版本.

UPDATE Since the Untitled property didn't work, let's try explicitly creating a copy of the file. I did not include any "cleanup" code to remove the copied versions.

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

您可以尝试的其他事情(不太可能奏效，但无论如何您都应该尝试一下):

Other things you could try (not likely to work, but you should try them anyways):

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

I notice that this code is executing from within PowerPoint, so one thing that doesn't make sense is the: Set PPTApp = CreateObject("PowerPoint.Application"). You're already running an instance of PPT, and only one instance of PPT runs (unlike Excel which can have multiple instances). So get rid of that line entirely.

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

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

Then also you can get rid of the variable PPTApp. I notice you use a combination of early- and late-binding for your PowerPoint Object Variables. That doesn't really make sense and while I wouldn't expect that to cause any errors, you never know.

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

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

If all else fails, open the new file WithWindow=msoTrue and step through the code line by line using F8...

更新 3

虽然我无法测试被另一个用户锁定/正在使用的文件，但我能够测试如果我有一个正在使用的文件会发生什么我自己.我使用以下代码并确定 Files 迭代最终将遇到文件的 lock/tmp 版本，以~"波浪号字符开头.这些通常是隐藏文件，但 FSO 无论如何都会在迭代中提取它们.

While I am not able to test a file that is locked/in-use by another user, I was able to test what happens if I have a file that is in use by myself. I use the following code and identify that the Files iteration will eventually encounter the lock/tmp version of the file, beginning with "~" tilde character. These are ordinarily hidden files, but FSO is picking them up in the iteration anyways.

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

Aside from that, I encounter similar errors if the file is not a valid PPT filetype (PPT, PPTX, PPTM, XML, etc.). I used the following code which prints a log of errors in the Immediate window (and informs you with MsgBox prompt) if there are errors.

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 文件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！