フォルダからPowerpointスライドのテキストボックスから文字列を削除 - エラーActiveXコンポーネントがオブジェクトを作成できません

Question

フォルダ内のすべてのpptをループして、スライド内のテキストボックスに文字列を削除したいと思います。

私はパワーポイントスライドで作業するのが初めてで、そのためにいくつかのヒントとアドバイスが必要です。

Option Compare Text 
Option Explicit 

Sub Test() 

Dim Sld As Slide, Shp As Shape 
Dim strFileName As String 
Dim strFolderName As String 
Dim PP As Presentation 
Dim strf As String 

'String to be deleted. 
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA") 

'Opens a PowerPoint Document from Excel 
Dim objPPT As Object 
Set objPPT = CreateObject("PowerPoint.Application") 
objPPT.Visible = True 


'set default directory here if needed 
strFolderName = "C:\Users\Desktop\Files" 
strFileName = Dir(strFolderName & "\*.ppt*") 

Do While Len(strFileName) > 0 

    objPPT.Presentations.Open strFolderName & "\" & strFileName 
    objPPT.Presentations.Activate 

    For Each Sld In ActivePresentation.Slides  'Error - ActiveX Component can't create object. 
     For Each Shp In Sld.Shapes 
      Select Case Shp.Type 
      Case MsoShapeType.msoTextBox 
       Debug.Print Sld.Name, Shp.Name, Shp.TextFrame.TextRange.Text 
      Case Else 
       Debug.Print Sld.Name, Shp.Name, "This is not a text box" 
      End Select 
     Next Shp 
    Next Sld 

    objPPT.Presentations.Close 
    strFileName = Dir 

Loop 

End Sub 

Answer 1

Excelでマクロを実行しているときは、アクティブプレゼンテーションの出所を忘れてしまいました。 objPPT.ActivePresentation.Slidesがあれば動作します。とにかく、あなたは改訂コードの下に試すことができます。

'Option Compare Text 
Option Explicit 

Sub Test() 

    'Dim Sld As Slide, Shp As Shape ' <-- Excel doesn't know Slide if Reference not added 
    Dim Sld As Object, Shp As Object 
    Dim strFileName As String 
    Dim strFolderName As String 
    'Dim PP As Presentation 
    Dim PP As Object ' Use this Presentation Object! 
    Dim strf As String 

    'String to be deleted. 
    strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA") 

    'Opens a PowerPoint Document from Excel 
    Dim objPPT As Object 
    Set objPPT = CreateObject("PowerPoint.Application") 
    objPPT.Visible = True ' <-- don't need this, for debug only 

    'set default directory here if needed 
    strFolderName = "C:\Users\Desktop\Files" 
    strFileName = Dir(strFolderName & "\*.ppt*") 

    Do While Len(strFileName) > 0 
     'objPPT.Presentations.Open strFolderName & "\" & strFileName 
     Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName) 
     'objPPT.Presentations.Activate 
     PP.Activate ' <-- don't need this, for debug only 
     'For Each Sld In ActivePresentation.Slides  'Error - ActiveX Component can't create object. 
     ' Should work if it's "objPPT.ActivePresentation.Slides" 
     For Each Sld In PP.Slides 
      For Each Shp In Sld.Shapes 
       With Shp 
        Select Case .Type 
         Case MsoShapeType.msoTextBox 
          If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then 
           Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text 
          Else 
           Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body" 
          End If 
         Case Else 
          Debug.Print Sld.Name, .Name, "This is not a text box" 
        End Select 
       End With 
      Next Shp 
     Next Sld 

     'objPPT.Presentations.Close 
     PP.Close 
     Set PP = Nothing 
     strFileName = Dir 
    Loop 

End Sub 

---

UPDATEを - すでに開いているファイルといくつかの調整を処理できるようにするには：

Option Explicit 

Sub Test() 

    Const strFolderName = "C:\Users\Desktop\Files\" 

    Dim objPPT As Object, PP As Object, Sld As Object, Shp As Object 
    Dim strFileName As String 
    Dim strf As String 

    'String to be deleted. 
    strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA") 
    If Len(Trim(strf)) = 0 Then Exit Sub ' Exit if blank text returned 

    'Opens a PowerPoint Document from Excel 
    Set objPPT = CreateObject("PowerPoint.Application") 

    'set default directory here if needed 
    strFileName = Dir(strFolderName & "*.ppt*") 

    Do While Len(strFileName) > 0 
     On Error Resume Next 
     ' Try to get existing one with same name 
     Set PP = objPPT.Presentations(strFileName) 
     ' If not opened, try open it 
     If PP Is Nothing Then Set PP = objPPT.Presentations.Open(strFolderName & strFileName) 
     On Error GoTo 0 
     ' Process the Presentation Slides if it's opened 
     If PP Is Nothing Then 
      Debug.Print "Cannot open file! """ & strFolderName & strFileName & """" 
     Else 
      Application.StatusBar = "Processing PPT file: " & PP.FullName 
      Debug.Print String(50, "=") 
      Debug.Print "PPT File: " & PP.FullName 
      For Each Sld In PP.Slides 
       For Each Shp In Sld.Shapes 
        With Shp 
         If .Type = MsoShapeType.msoTextBox Then 
          If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then 
           Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text 
          Else 
           Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body" 
          End If 
         End If 
        End With 
       Next Shp 
      Next Sld 
      PP.Close ' Close the Presentation 
      Set PP = Nothing 
     End If 
     strFileName = Dir 
    Loop 
    Application.StatusBar = False 
    ' Quit PowerPoint app 
    objPPT.Quit 
    Set objPPT = Nothing 
End Sub 

Answer 2

エラーが表示されません。私はコードが動作することも期待していたでしょう。しかし、私は前にこの問題につまずいたと作品（妙）以下の解決策が見つかりました：

Option Compare Text 
Option Explicit 

Sub Test() 

Dim Sld As Long, Shp As Long 
Dim strFileName As String 
Dim strFolderName As String 
Dim PP As PowerPoint.Presentation 
Dim strf As String 

'String to be deleted. 
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA") 

'Opens a PowerPoint Document from Excel 
Dim objPPT As PowerPoint.Application 
Set objPPT = New PowerPoint.Application 
objPPT.Visible = True 


'set default directory here if needed 
strFolderName = "C:\Users\Desktop\Files" 
strFileName = Dir(strFolderName & "\*.ppt*") 

Do While Len(strFileName) > 0 

    Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName) 
    'objPPT.Presentations.Activate 

    For Sld = 1 To PP.Slides.Count 
     For Shp = 1 To PP.Slides.Item(Sld).Shapes.Count 
      With PP.Slides.Item(Sld).Shapes.Item(Shp) 
       Select Case .Type 
       Case MsoShapeType.msoTextBox 
        Debug.Print .Name, .Name, .TextFrame.TextRange.Text 
       Case Else 
        Debug.Print .Name, .Name, "This is not a text box" 
       End Select 
      End With 
     Next Shp 
    Next Sld 

    PP.Close 
    Set PP = Nothing 
    strFileName = Dir 

Loop 

objPPT.Quit 
Set objPPT = Nothing 

End Sub 

注：このソリューションは、事前バインディングの代わりに、遅延バインディング使用していますが。したがって、Microsoft PowerPoint xx.x Object Libraryへの参照を追加する必要があります。