SmartArtからテキストを取得するPowerPointマクロ

ホーム
Office関連, PowerPoint
SmartArtからテキストを取得するPowerPointマクロ

2015.07.8

SmartArtからテキストを取得するPowerPointマクロ

Twitterで@terrysaitoさんが下記のようなツイートをされていました。

VBAでSmartArtの文字列を抜く方法を、誰か伝授して下さらぬか？

— Terry Saito / 齊藤貴昭 (@terrysaito) 2015, 7月 7

そういえばマクロでSmartArtを意識して取り扱ったことなかったなー、と思い、良い機会なのでコードを書いてみることにしました。

Public Sub Sample1()
  Dim shp As PowerPoint.Shape
  Dim s As PowerPoint.Shape
  
  'スライド1の図形を順次処理
  For Each shp In Application.ActivePresentation.Slides(1).Shapes
    'SmartArtのみ処理
    If shp.Type = msoSmartArt Then
      If shp.GroupItems.Count > 0 Then
        For Each s In shp.GroupItems
          If s.HasTextFrame = True Then
            If s.TextFrame2.HasText = True Then
              Debug.Print s.TextFrame2.TextRange.Text
            End If
          End If
        Next
      End If
    End If
  Next
End Sub

まずはShapeオブジェクトのTypeプロパティでSmartArtかどうかを判別し、グループ内の図形を取得するGroupItemsプロパティを使って順番にテキストを取得するコードです。
下図のスライドに対しコードを実行すると、

下図のような結果になります。
図中にある矢印内のテキストも取得しています。

今度はHasSmartArtプロパティでSmartArtかどうかを判別し、SmartArtNodeオブジェクトから順番にテキストを取得するコードです。

Public Sub Sample2()
  Dim shp As PowerPoint.Shape
  Dim n As Office.SmartArtNode
  
  'スライド1の図形を順次処理
  For Each shp In Application.ActivePresentation.Slides(1).Shapes
    'SmartArtのみ処理
    If shp.HasSmartArt = True Then
      For Each n In shp.SmartArt.AllNodes
        If n.TextFrame2.HasText = True Then
          Debug.Print n.TextFrame2.TextRange.Text
        End If
      Next
    End If
  Next
End Sub

結果は下図の通りで、こちらは図中の矢印のテキストを取得できていません。
矢印はノードに含まれていないようです。

この結果からすると、テキストを取得する際はGroupItemsプロパティ(GroupShapesオブジェクト)を使った方が漏れが無さそうです。

ただし、ノードを追加したりレイアウトを変更したりするときは、専用のプロパティやメソッドが用意されたSmartArtオブジェクトを使った方が良いでしょう。
(SmartArtかどうかは、ShapeオブジェクトのTypeプロパティとHasSmartArtプロパティのどちらでも判別できるようです。)

以上、SmartArtからテキストを取得するマクロの紹介でした。

2015/7/8 追記：

@terrysaitoさんから下記返信がありました。

@kinuasa 一つ目試しました。13行目で「このメンバにアクセスできるのは、単一の図形の場合だけです」というエラーになりました<(_ _)> @SHINHAM3

— Terry Saito / 齊藤貴昭 (@terrysaito) 2015, 7月 8

このツイートからすると引っ掛かっているのはグループ化されている図形でしょうか？
この際SmartArtかどうか無視して再帰的に処理するマクロも考えてみました。

Option Explicit

Public Sub Sample()
  Dim shp As PowerPoint.Shape
  
  For Each shp In Application.ActivePresentation.Slides(1).Shapes
    ListShape shp
  Next
End Sub

Private Sub ListShape(ByVal TargetShape As PowerPoint.Shape)
  Dim gshps As PowerPoint.GroupShapes
  Dim shp As PowerPoint.Shape
  
  On Error Resume Next
  Set gshps = TargetShape.GroupItems
  On Error GoTo 0
  If Not gshps Is Nothing Then
    If gshps.Count > 0 Then
      For Each shp In gshps
        ListShape shp
        DoEvents
      Next
    End If
  End If
  
  If TargetShape.HasTextFrame = True Then
    If TargetShape.TextFrame2.HasText = True Then
      GetShapeText TargetShape
    End If
  End If
End Sub

Private Sub GetShapeText(ByVal TargetShape As PowerPoint.Shape)
  Debug.Print TargetShape.TextFrame2.TextRange.Text
End Sub

あとは、数年前に「各スライドに配置されたオートシェイプからテキストを取得するPowerPointマクロ」も書いたことがあるので、そちらが参考になるのかもしれません。

2015/7/8 追記2：

@terrysaitoさんのツイートによると、やっぱり上手くいかないとのこと。

@kinuasa 早速ありがとうございます。結論から言うと35行で同じエラーでした(^_^;) 古い記事は既に拝読してまして SmartArtNodeで引っ掛かるので、他の方法を探していたのでした(^^) @SHINHAM3

— Terry Saito / 齊藤貴昭 (@terrysaito) 2015, 7月 8

私にも理由が分からなかったのですが、検索したらヒントがありました。

・How to access textrange members inside SmartArt
https://groups.google.com/d/topic/microsoft.public.powerpoint/zkg4d5Ioh5A/discussion

for (int i=1;i<=textRange.Count;i++) { TextRange ranger=textRange._item(1); ....... }

“TextRange(TextRange2)オブジェクトってコレクションだったのか！？”と。

であれば、For Eachでループさせれば上手くいくかもしれません。
(私の方では問題環境が再現できなかったので未確認です。)

Option Explicit

Public Sub Sample()
  Dim shp As PowerPoint.Shape
  
  For Each shp In Application.ActivePresentation.Slides(1).Shapes
    ListShape shp
  Next
End Sub

Private Sub ListShape(ByVal TargetShape As PowerPoint.Shape)
  Dim gshps As PowerPoint.GroupShapes
  Dim shp As PowerPoint.Shape
  Dim trng As Office.TextRange2
  
  On Error Resume Next
  Set gshps = TargetShape.GroupItems
  On Error GoTo 0
  If Not gshps Is Nothing Then
    If gshps.Count > 0 Then
      For Each shp In gshps
        ListShape shp
        DoEvents
      Next
    End If
  End If
  
  If TargetShape.HasTextFrame = True Then
    If TargetShape.TextFrame2.HasText = True Then
      For Each trng In TargetShape.TextFrame2.TextRange
        GetTextRangeText trng
      Next
    End If
  End If
End Sub

Private Sub GetTextRangeText(ByVal TargetTextRange As Office.TextRange2)
  Debug.Print TargetTextRange.Text
End Sub