Excel VBA读取PowerPoint文本框异常：PPT打开时生成副本而非读取原文件

你的问题核心是：当目标PPT处于打开状态时，直接调用Presentations.Open会触发PowerPoint的副本打开机制（原文件被已打开进程锁定），导致代码读取的是副本内容而非修改后的原文件。

解决思路是：优先检查目标PPT是否已打开，若已打开则直接引用该实例；未打开再执行打开操作，同时避免重复创建PowerPoint进程。

修改后的代码 #

Sub ExtractPowerPointTextBoxes()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim ws As Worksheet
    Dim pptPath As String
    
    pptPath = ThisWorkbook.Path & "\floor_planning_test.pptx"
    
    ' 优先获取已运行的PowerPoint实例，无则新建
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
        pptApp.Visible = True
    End If
    
    ' 检查目标PPT是否已打开
    Set pptPres = Nothing
    On Error Resume Next
    For Each pptPres In pptApp.Presentations
        If StrComp(pptPres.FullName, pptPath, vbTextCompare) = 0 Then
            Exit For
        End If
    Next
    On Error GoTo 0
    
    ' 未打开则执行打开操作
    If pptPres Is Nothing Then
        Set pptPres = pptApp.Presentations.Open(pptPath)
    End If
    
    ' 绑定目标工作表并提取内容
    Set ws = ThisWorkbook.Sheets("Sheet1")
    With pptPres.Slides(1)
        ws.Range("A1").Value = .Shapes("TextBox-1").TextFrame.TextRange.Text
        ws.Range("A2").Value = .Shapes("TextBox-2").TextFrame.TextRange.Text
        ws.Range("A3").Value = .Shapes("TextBox-3").TextFrame.TextRange.Text
    End With
    
    ' 清理对象
    Set ws = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    
    MsgBox "数据提取成功", vbInformation
End Sub

关键优化点 #

• 用GetObject复用已运行的PowerPoint进程，避免重复启动程序
• 遍历Presentations集合匹配目标文件，直接引用已打开的演示文稿
• 用StrComp做路径的不区分大小写比对，规避系统路径大小写差异问题
• 简化代码结构，移除冗余的重复赋值操作

内容的提问来源于stack exchange，提问作者wycliff