【Word VBA】文書中のテキストボックス内の文字列を別紙に書出す(その3)

これまでに、「【コード】文書中のテキストボックス内の文字列を別紙に書出すコード」と「【コード】文書中のテキストボックス内の文字列を別紙に書出す(その2)」を紹介しました。

上記のマクロでは、描画キャンバス内のテキストボックスを処理できていません。

さらに、グループ内のさらにグループ化されたテキストボックスも処理できていません。

そのようなわけで、今回は描画キャンバスやグループ化をもう少し掘り下げて検証します。

なお、今回の記事もまだ完璧ではありません。プログラムを簡単にするために、ヘッダーやフッター内のテキストボックスは処理対象から外しているからです。

WordのヘッダーやフッターをVBAで処理するには変則的なことをする必要があります。バグのような特殊な仕様があるからです。

そのため、理解しやすいように、本文内にあるテキストボックスだけを処理対象にしてみました。

なお、このマクロにもまだエラーが発生することがあります。「その4」以降に続きます。

このマクロでできること

本文中に書かれているテキストボックス内の文字列を新規文書に書き出します。

ヘッダーやフッター内のテキストボックスは処理対象外です。

描画キャンバス内のテキストボックスやグループ化されているテキストボックスも処理対象にしています。

また、描画キャンバス内のグループ化されたテキストボックス内のグループ化されたテキストボックス、、、、など、考え始めると結構複雑な構造になりえます。

このような場合には、再帰処理をして描画キャンバスやグループを取り扱います。

以下のような描画キャンバス内にグループ化されたテキストボックスがある場合にもテキストを書き出せます。

テキストボックス

以下のように新規文書にテキストボックス内の文字列を書き出します。(以下の例は、Word 2007で実行した場合)

抽出したテキスト

マクロ1の解説

GetTextという名前のサブプロシージャーを再帰呼び出しという方法で実行します。

CanvasItemsプロパティGroupItemsプロパティを用いて描画キャンバス内、グループ内のShapeオブジェクトを特定します。

マクロ1


Sub テキストボックスのテキスト抽出3()

 Dim myShape As Shape   '図
 Dim actDoc As Document '処理対象の文書
 Dim newDoc As Document  '新規で開いた文書
 
 Set actDoc = ActiveDocument
 Set newDoc = Documents.Add

 For Each myShape In actDoc.Shapes
  Call GetText(myShape, newDoc)
 Next
 
 Set actDoc = Nothing
 Set newDoc = Nothing

End Sub

Private Sub GetText(aShape As Shape, myDoc As Document)

 Dim InShape As Shape  'グループ内の図

 Select Case aShape.Type

  'キャンバスの場合の処理
  Case msoCanvas
   For Each InShape In aShape.CanvasItems
    Call GetText(InShape, myDoc)
   Next InShape

  'グループ化されている場合の処理
  Case msoGroup
   For Each InShape In aShape.GroupItems
    Call GetText(InShape, myDoc)
   Next InShape

  '上記以外の場合の処理(テキスト抽出)
  Case Else
   If aShape.TextFrame.HasText = True Then
     myDoc.Range.InsertAfter aShape.TextFrame.TextRange.Text
   End If

 End Select

End Sub

マクロ2の解説

実は、マクロ1は、Word 2003, Word 2007とWord 2013以降のバージョンであれば動きます。Word 2010では動きません。

私はWord 2010でサンプルコードを書いていたので、理論上は動くと思われるマクロ1が動かなくて無駄に考え込んでしまっていました。

Word 2010では以下のようなエラーメッセージが表示されます。

エラーメッセージ

これはバグだと思います。何が問題なのでしょうか。

以下の箇所でエラーで止まります。

つまり、For Each Next ステートメントが問題になっているのです。ここでメンバー(InShape)を取り出せなくて、エラーになります。

エラー

GroupItemsはあるはず、、、と思ってGroupItems.Countプロパティを調べると数が表示されるのです。

納得いかないけど、とりあえずインデックス番号でオブジェクトを特定しようか、、と思ってマクロ2の用に修正したら動きました。

「おかしいなー」と思ってEvernoteに書きためたバグのメモを探してみると、、、、。ありました(笑)。

この挙動については以前他のプログラムでも起こりました。Word 2010のバグのような現象としてメモしてました。ひとまずは、マクロ2のように修正して動くのでよしとします。

マクロ2


Sub テキストボックスのテキスト抽出4()

 Dim myShape As Shape   '図
 Dim actDoc As Document '処理対象の文書
 Dim newDoc As Document  '新規で開いた文書
 
 Set actDoc = ActiveDocument
 Set newDoc = Documents.Add

 For Each myShape In actDoc.Shapes
  Call GetText(myShape, newDoc)
 Next
 
 Set actDoc = Nothing
 Set newDoc = Nothing

End Sub

Private Sub GetText(aShape As Shape, myDoc As Document)
 
 Dim i As Integer
 Dim iMax As Integer

 Select Case aShape.Type

  'キャンバスの場合の処理
  Case msoCanvas
   iMax = aShape.CanvasItems.Count
   For i = 1 To iMax
    Call GetText(aShape.CanvasItems(i), myDoc)
   Next i
   
  'グループ化されている場合の処理
  Case msoGroup
   iMax = aShape.GroupItems.Count
   For i = 1 To iMax
    Call GetText(aShape.GroupItems(i), myDoc)
   Next i
   
  '上記以外の場合の処理(テキスト抽出)
  Case Else
   If aShape.TextFrame.HasText = True Then
     myDoc.Range.InsertAfter aShape.TextFrame.TextRange.Text
   End If

 End Select

End Sub

関連記事

トップへ戻る