VBA 代码从 Powerpoint 文本框更新 Excel，但如果 PPT 打开，它会创建 PPT 文件的副本，而不是编辑现有文件

Question

我在 Excel 上有一个 VBA 代码，运行时，它会从 Power Point 文本框中获取文本，并更新 Excel 文件中的特定单元格。

如果我更新 PowerPoint、关闭它，然后打开 Excel 文件并运行 VBA，则效果很好。但是，如果我在运行代码时打开 Power Point 文件，它会创建 Power Point 文件的新副本，而不是对现有文件进行更改。

Sub ExtractPowerPointTextBoxes()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim pptTextBoxes As Object
    Dim ws As Worksheet
    
    ' Open PowerPoint application
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    ' Open the PowerPoint presentation
    Set pptPres = pptApp.Presentations.Open(ThisWorkbook.Path & "\floor_planning_test.pptx")
    
    ' Set the worksheet to paste data
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Set the slide to the first slide
    Set pptSlide = pptPres.Slides(1)
    
    ' Set the text boxes
    Set pptTextBoxes = pptSlide.Shapes
    
    ' Extract the data from PowerPoint and paste it into Excel
    ws.Range("A1").Value = pptTextBoxes("TextBox-1").TextFrame.TextRange.Text
    ws.Range("A2").Value = pptTextBoxes("TextBox-2").TextFrame.TextRange.Text
    ws.Range("A3").Value = pptTextBoxes("TextBox-3").TextFrame.TextRange.Text
    
    ' Set the text boxes
    Set pptTextBoxes = pptSlide.Shapes
       
    ' Clean up
    Set pptTextBoxes = Nothing
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    
    MsgBox "Data extracted successfully", vbInformation
End Sub

Answer 1

微软文档：

获取对象函数

Sub ExtractPowerPointTextBoxes()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim pptTextBoxes As Object
    Dim ws As Worksheet
    Const PPT_FILE = "floor_planning_test.pptx"
    ' Get existing App
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp is Nothing Then
        ' Open PowerPoint application
        Set pptApp = CreateObject("PowerPoint.Application")
        pptApp.Visible = True        
    End If
    ' Get the opened Presentation
    For Each pptPres In pptApp.Presentations
        If pptPres.Name = PPT_FILE Then Exit For
    Next
    If pptPres is Nothing Then
        ' Open the PowerPoint presentation
        Set pptPres = pptApp.Presentations.Open(ThisWorkbook.Path & "\floor_planning_test.pptx")
    End If
    ' Set the worksheet to paste data
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' Set the slide to the first slide
    Set pptSlide = pptPres.Slides(1)
    ' Set the text boxes
    Set pptTextBoxes = pptSlide.Shapes
    ' Extract the data from PowerPoint and paste it into Excel
    ws.Range("A1").Value = pptTextBoxes("TextBox-1").TextFrame.TextRange.Text
    ws.Range("A2").Value = pptTextBoxes("TextBox-2").TextFrame.TextRange.Text
    ws.Range("A3").Value = pptTextBoxes("TextBox-3").TextFrame.TextRange.Text
    ' Set the text boxes
    Set pptTextBoxes = pptSlide.Shapes
    pptPres.Save   ' Save ppt, modify as needed 
    ' Clean up
    Set pptTextBoxes = Nothing
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    MsgBox "Data extracted successfully", vbInformation
End Sub