遊ぶエンジニア

Sub Title2txt()
  
  Dim objSlide As Slide
  Dim fso As Object
  Dim stream As Object
  Dim title As String
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set stream = fso.OpenTextFile(ActivePresentation.Name + ".txt", 8, True)

  For Each objSlide In ActivePresentation.Slides
    If objSlide.Shapes.HasTitle Then
      title = objSlide.Shapes.title.TextFrame.TextRange.Text
      title = Replace(title, vbCrLf, "")
      On Error GoTo show_error
        stream.writeline title
resume_p1:
      On Error GoTo 0
      
    End If
  Next


  stream.Close

  MsgBox "タイトルの抽出が、完了しました。"

  Exit Sub
  
show_error:
  stream.writeline "***unprintable line***"
  Resume resume_p1

End Sub

VB Editorでモジュールにでも貼って実行。後は、捨ててオリジナルは変更しないでもOK
7月9日、抽出できないタイトルがあるので、エラーコードを書くことにした。
できないものがあることに注意してください。