こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

投稿日時 - 2008-06-13 12:12:25

QNo.4097231

すぐに回答ほしいです

質問者が選んだベストアンサー

こんばんは。

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

> 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-15 00:13:25

お礼

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

投稿日時 - 2008-06-26 09:43:04

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問