PowerPointのスライドに対し、索引を作成する(1)

PPTファイルのスライドの内容を、ノート部分も含めてすべてテキストファイルに出力する

Option Explicit
Sub Extract()

    Dim myFilePath As String
    ' 書き出しファイルを指定する
    myFilePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
               "\" & ActivePresentation.Name & ".xml"

    Open myFilePath For Output As #1

    Print #1, "<?xml version='1.0' encoding='Shift_JIS' ?>" & vbCrLf
    Print #1, "<Slides>" & vbCrLf

    Dim pSlide As slide
        
    For Each pSlide In ActiveWindow.Parent.Slides
        Print #1, "<Slide><SlideNumber value='" & pSlide.SlideNumber & "'/>" & vbCrLf
        Print #1, "<SlideBody><![CDATA[" & vbCrLf
        
        ' スライドのテキストを全部表示する
        Dim pShape As Shape
        For Each pShape In pSlide.Shapes
            If pShape.HasTextFrame Then
                If pShape.TextFrame.HasText Then
                    With pShape.TextFrame.TextRange
                        Print #1, CleanChar(.Text)
                    End With
                End If
            End If
        Next
        
        ' ノートのテキストを全部表示する
        For Each pShape In pSlide.NotesPage.Shapes
            If pShape.HasTextFrame Then
                If pShape.TextFrame.HasText Then
                    With pShape.TextFrame.TextRange
                        Print #1, CleanChar(.Text)
                    End With
                End If
            End If
        Next
    
        Print #1, "]]></SlideBody>" & vbCrLf
        Print #1, "</Slide>" & vbCrLf
    Next

    Print #1, "</Slides>"

    Close #1

End Sub

' http://www.tsware.jp/tips/tips_406.htm
' 上記サイトから引用
Private Function CleanChar(strData As String) As String
'引数の文字列から制御コードを除去した文字列を返す

  Dim strRet As String
  Dim strCurChar As String
  Dim iintLoop As Integer

  strRet = ""
  For iintLoop = 1 To Len(strData)
    strCurChar = Mid$(strData, iintLoop, 1)
    If Asc(strCurChar) < 0 Or Asc(strCurChar) >= 32 Then
      '漢字のAscの返り値はマイナスに留意
      strRet = strRet & strCurChar
    End If
  Next iintLoop

  CleanChar = strRet

End Function