先日テキストボックス内の文字列に対する置換処理のマクロをご紹介しました。
今回は、テキストボックス内にある文字列を書出すマクロです。
今の仕事でどうしても必要になっており、作ってみました。
＜目次＞
このマクロでできること
文書中のテキストボックス内の文字列を、新しい文書に書出します。
この記事でのテキストボックスとは、図に書かれている文字列や吹き出しの文字列を意味します。
グループ化されているテキストボックスからもテキストを抽出できます。
これは、きぬあささんのブログでご紹介いただいた方法を使いました。
描画キャンバスにおいても、同じような考え方で応用できそうですが、まだ検証が終わっていないので今回は除外いたしました。
マクロの解説
文書中の全ての図から文字列を探します。
図が画像の場合には、文字列がありませんので、文字列を取得しようとするとエラーになります。
このときのエラー番号は5917です。
エラーが出ていない場合に取得したテキストを文書に貼り付けています。
エラーが出た場合には、エラーをクリアします。
マクロ
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | Sub テキストボックスのテキスト抽出() Dim aShape As Shape '図 Dim grpShape As Shape 'グループ化された図 Dim myText As String '抽出する文字列 Dim actDoc As Document '処理対象の文書 Dim myDoc As Document '新規で開いた文書 Set actDoc = ActiveDocument Set myDoc = Documents.Add actDoc.Activate For Each aShape In ActiveDocument.Shapes Select Case aShape.Type Case msoGroup 'グループ化されている場合の処理 For Each grpShape In aShape.GroupItems On Error Resume Next myText = grpShape.TextFrame.TextRange.Text '図中にテキストの有無の判定 If Err.Number <> 5917 Then myDoc.Range.InsertAfter myText Else Err.Clear End If On Error GoTo 0 Next Case Else 'それ以外の場合の処理 On Error Resume Next myText = aShape.TextFrame.TextRange.Text '図中にテキストの有無の判定 If Err.Number <> 5917 Then myDoc.Range.InsertAfter myText Else Err.Clear End If On Error GoTo 0 End Select Next myDoc.Activate Set myDoc = Nothing End Sub |