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