VBAでPowerPointからExcelにデータを抽出する

大量のPowerPointファイルに、それぞれオブジェクトがあり、そのオブジェクトの内容をVBAでExcelに書き出したいのですが、可能でしょうか？
具体的にはPowerPointにテキストボックスがあり、その文章をExcelのセルに書き出したいのです。
どのようにコーディングすればいいでしょうか？
できればExcelVBAでできれば、うれしいです。
OSはXPで、Office2003です。
よろしくお願いします。

No.1 ベストアンサー 回答者： KenKen_SP 回答日時： 2008/06/15 00:13

こんばんは。

> どのようにコーディングすればいいでしょうか？
ご自分でどこまでできてます？

> VBAでExcelに書き出したいのですが、可能でしょうか？
可能です。適当に書いたものですが下記のような感じとか。

注意点は、Shape のインデックス順の抽出になります。レイアウト通りの
順番で抽出できるとは限りません。レイアウト通りと思えば、非常に
面倒だと思います。（※この点の解決案は後述の参考 URL 参照）

なお、私なら多分外部ツールと組み合わせますよ。

[xdoc2txt] － PDF,WORD,EXCEL,一太郎などからテキストを抽出
http://www31.ocn.ne.jp/~h_ishida/xdoc2txt.html

この関連で Web 検索するとこんな記事がありました。

[パワーポイントからテキストを抽出]
http://www.ctrans.org/gobi/1156579633

ご参考までに。

' // フォルダ内の *.ppt ファイルからテキストを抽出する
Sub OutputText()

　　Dim ppApp　 As Object ' // PowerPoint.Application
　　Dim ppPre　 As Object ' // PowerPoint.Presentation
　　Dim ppShp　 As Object ' // PowerPoint.Shape
　　Dim ppSld　 As Object ' // PowerPoint.Slide
　　Dim sPath　 As String
　　Dim sFnam　 As String
　　Dim i　　　 As Long
　　Dim sh　　　As Worksheet
　　
　　' // 処理対象のフォルダパス
　　sPath = "C:\"
　　
　　' // 初回ファイル検索
　　sFnam = Dir$(sPath & "\" & "*.ppt")
　　If Len(sFnam) = 0 Then
　　　　MsgBox "*.ppt が見つかりません", vbInformation
　　　　Exit Sub
　　End If
　　
　　On Error GoTo Err_
　　
　　' // PowerPoint起動
　　Set ppApp = CreateObject("PowerPoint.Application")
　　ppApp.Visible = True
　　' // 出力シート作成
　　Set sh = Workbooks.Add.Sheets(1)
　　With sh.Range("A1:D1")
　　　　.Font.Bold = True
　　　　.Value = Array("Filename", "Slide Number", "Shape Name", "Text")
　　End With
　　
　　' // リスト開始行番号
　　i = 2
　　' // *.ppt が見つからなくなるまでループ
　　Application.ScreenUpdating = False
　　While Len(sFnam) > 0
　　　　' // Presentation を開き、全ての Slide -その中の全ての Shape について
　　　　' // テキストがあればセルに出力する
　　　　Set ppPre = ppApp.Presentations.Open(Filename:=sPath & "\" & sFnam, _
　　　　　　　　　　　　　　　　　　　　　　 ReadOnly:=True)
　　　　For Each ppSld In ppPre.Slides
　　　　　　For Each ppShp In ppSld.Shapes
　　　　　　　　If ppShp.HasTextFrame Then
　　　　　　　　　　sh.Cells(i, "A").Value = sFnam
　　　　　　　　　　sh.Cells(i, "B").Value = ppSld.SlideNumber
　　　　　　　　　　sh.Cells(i, "C").Value = ppShp.Name
　　　　　　　　　　sh.Cells(i, "D").Value = Replace$(ppShp.TextFrame.TextRange.Text, _
　　　　　　　　　　　　　　　　　　　　　　　　　　　vbCr, vbLf)
　　　　　　　　　　i = i + 1
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　　　' // Presentation を閉じ、次のファイルを検索
　　　　ppPre.Close
　　　　Set ppPre = Nothing
　　　　sFnam = Dir$()
　　Wend
　　ppApp.Quit
　　sh.Columns.AutoFit
　　sh.Rows.AutoFit

Bye_:
　　Set ppApp = Nothing
　　Set sh = Nothing
　　Exit Sub
Err_:
　　MsgBox Err.Description, vbCritical
　　Resume Bye_
End Sub

この回答へのお礼

ありがとうございました。非常に勉強になりました。またよろしくお願いします。

お礼日時：2008/06/26 09:43