エクセルからパワーポイントのテキストコメントと設定を取得したい

Question

エクセルからパワーポイントファイルの
テキストボックスの文章・余白・左寄せなどをリスト化したいと思っています。
エクセルとパワーポイントは2002を使用しています。

c:\testフォルダに入っているパワーポイントファイルを開き、
A1～J1のセルに
パワーポイントのテキストボックスのコメントや
左寄せ右寄せなどの設置値（1や2など）
余白の自動設定の有無（trueやfalseなど）
余白の上下左右値を取得したいです。（数値）

現在のコードでは余白の抽出や左寄せの部分で
エラーになりうまく動きません。

すみませんが教えて下さい。

コード
' // フォルダ内の *.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:\test\"
  
    ' // 初回ファイル検索
    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:J1")
        .Font.Bold = True
        .Value = Array("Filename", "Slide Number", "Shape Name", "Text", "Alignment", "AutoMargins", "MLeft", "MTop", "MRight", "MBottom")
    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, "E").Value = ppShp.TextFrame.ParagraphFormat.Alignment '//寄せ位置を数字で表示したい
                 sh.Cells(i, "F").Value = ppShp.TextFrame.AutoMargins               '//自動チェックのfalseかtrueを表示したい
                 sh.Cells(i, "G").Value = ppShp.TextFrame.MarginLeft                '//余白左側の数値
                 sh.Cells(i, "H").Value = ppShp.TextFrame.MarginTop                 '//余白上側の数値
                 sh.Cells(i, "I").Value = ppShp.TextFrame.MarginRight               '//余白右側の数値
                 sh.Cells(i, "J").Value = ppShp.TextFrame.MarginBottom              '//余白下側の数値
                    
                    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

Answer 1

はじめまして、thom.jpです。

手元のバージョンが2010なので、断言はできませんが、、
ParagraphFormatはTextFrame.TextRangeのプロパティかと思われますので、飛ばして書けないと思います。
ExcelのShape.TextFrameにはAutoMarginsがありますが、PowerPointには無いように思えます。

VBEからPowerPointを参照設定すると、オブジェクトブラウザでパワポのシェイプについて確認できますが、そちらで確認したところ、TextFrameにAutoMarginsプロパティは無いですね。

Excel、PowerPoint、Wordのシェイプはそれぞれ微妙に定義の異なるオブジェクトなので、代替手段が無さそうなら諦めるしかなさそうです。

Comments

[OMUSUBI]

thom.jpさん
返答ありがとうございます。

余白のプロパティーをなんとかできないのか思っていたのですが、
パワーポイントにはAutomaraginsプロパティーは無いのですね。
エクセルに貼り付けた時にレイアウトが崩れるのは
それが原因なのかなと思いました。
アドバイス頂いた様に
代替手段を考えてみて諦めるかどうかしたいと思います。
ありがとうございました。