エクセルVBAからパワーポイントファイル内の構成内容をリスト化したい

エクセルのマクロからパワーポイントのスライド内に配置されているテキストや画像を把握し、
エクセル内にテキストの内容や画像を部品としてリスト化できるものができないかと思っています。

下記の様にテキストと画像やオートシェイプをリスト化したいと思っています。
EXCEL2002 POWERPOINT2002を使用しています。

1行でパワーポイント内のテキストなどの情報をまとめてあり、
E・F・G・H列に
パワーポイント内のテキスト・画像・オートシェイプの
座標と範囲の表示、

D列に
種類によって、テキスト、画像、オートシェイプがセルサイズに
合わせて貼り付けられる様にしたいと思っています。

うまくいかない点は
・画像やオートシェイプを抽出しセルにあてはめる事ができない
・alt＋enterで改行されている文章が改行されず抽出されてしまう。
・パワーポイントのテキストボックスをそのままセルに貼り付けたい場合は画像の抽出の様に設定すれば良いか知りたい

助言を頂いた方にはできるだけ速く確認し返答したいと思っていますが、
返答が遅い時間になってしまうかもしれませんが
どうぞ宜しくお願いします。

コード
' // フォルダ内の *.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:I1")
        .Font.Bold = True
        .Value = Array("Filename", "Slide Number", "Shape Name", "Text or image ", "Left", "Top", "Width", "Height")
    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)  '//貼り付け後改行が無くなってしまう
                    'sh.Cells(i, "D").Value =    //画像をセルへ貼り付けてセルのサイズに合わせたい
                    sh.Cells(i, "E").Value = ppShp.Left  'テキストや画像 画面左からの位置
                    sh.Cells(i, "F").Value = ppShp.Top
                    sh.Cells(i, "G").Value = ppShp.Width
                    sh.Cells(i, "H").Value = ppShp.Height
                    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

行動規範の内容に同意します

回答1件

ベストアンサー

・改行
セルの表示形式で「折り返して表示」にすると改行が反映される可能性が高いです。

・シェイプ
シェイプの貼り付けは直感的に分かりにくいのですが、
コピー : Shape.Copy
ペースト: Sheet.Paste
で貼り付けることができるはずです(Excel 2010で動作確認済)

投稿2015/12/17 02:41

ExcelVBAer

総合スコア1175

OMUSUBI

2015/12/17 14:59

回答ありがとうございます。連絡が遅くなりすみません。すみませんマクロ初心者で色々試してみたのですがアドバイス頂いたコピーペーストのコードで動かす事ができませんでした。 sh.Cells(i, "D").Value = Replace$(ppShp.TextFrame.TextRange.Text, _ vbCr, vbLf) '//貼り付け後改行が無くなってしまうの行の下に activepresentation.ppshp.copy 'powerpoint内のオブジェクトをコピー sh.cells(i,"d").paste 　　　　　　　’セルdにペーストを追加してみたりしたのですが駄目でした。できれば動作確認できたコードを教えて頂きたいです。すみませんが宜しくお願いします。