【Word VBA】Word文書中の蛍光ペンのテキストを抽出するWordマクロ

2011年11月13日

, ,

先日の文書中のテキストボックス内の文字列を別紙に書出すマクロ に引き続いて、テキストの抽出用マクロです。

記事をご覧になった読者の方から、質問がありまして作ってみました。

このマクロでできること

Word文書中の本文中の蛍光ペンで着色された文字列をテキスト（書式無し）として別紙に書出します。

抽出したテキスト毎に改行をして列挙します。

マクロの解説

23行目

特定の文書で検索をした場合、文書最後の蛍光ペンを検出した後、次の蛍光ペンの検出判定が空の文字列に対して起こることがありました。

その場合、無限ループに入ってしまうので、蛍光ペンが見つかった場合には、文字列が少なくとも含まれているかどうかを判定しています。

25行目、26行目

改行記号（vbCR）も蛍光ペンで着色しうるのですが、改行記号の蛍光ペンが検出された場合には無視することにしました。

今回のマクロではあくまでもテキスト情報を取り出すことが目的ですので、改行記号が書出されると読みづらくなりますのでこのような処理としました。

実は、改ページ記号にも蛍光ペンで着色できますので、同様の処理を改ページ記号にしてもいいかもしれません。

30行目、39行目

テキストを書出した後に改行をしています。

ここに、文字列を入れる場合には、代わりに以下のメソッドを追記してもします。

.InsertAfter "追記する文字列"

コンマやタブで区切ることができますね。

マクロ


Sub 蛍光ペンのテキスト抽出()

　Dim myRange As Range　　'Rangeオブジェクト
　Dim myText As String　　'抽出する文字列
　Dim newDoc As Document　'新規で開いた文書

　'画面の更新をオフ
　Application.ScreenUpdating = False

　Set myRange = ActiveDocument.Range(0, 0)
　Set newDoc = Documents.Add

　With myRange.Find
　　.Text = ""
　　.Forward = True
　　.Wrap = wdFindStop
　　.Highlight = True
　End With

　'文書の最後の蛍光ペン後は、蛍光ペンが
　'なくても検索されたと判定されることがあるため回避する処理
　Do While myRange.Find.Execute = True And _
　　myRange.Text <> ""

　　If InStr(myRange.Text, vbCr) Then
　　　If myRange.Text <> vbCr Then
　　　　myRange.End = myRange.End - 1
　　　　With newDoc.Range
　　　　　.InsertAfter myRange.Text
　　　　　.InsertParagraphAfter
　　　　　myRange.Collapse direction:=wdCollapseEnd
　　　　End With
　　　Else
　　　　'蛍光ペンが改行記号の場合は無視
　　　End If
　　Else
　　　With newDoc.Range
　　　　.InsertAfter myRange.Text
　　　　.InsertParagraphAfter
　　　　myRange.Collapse direction:=wdCollapseEnd
　　　End With
　　End If

　Loop

　Set newDoc = Nothing
　Set myRange = Nothing

　'画面の更新をオン
　Application.ScreenUpdating = True

End Sub

関連記事

文書中のテキストボックス内の文字列を別紙に書出すマクロ

蛍光ペンのある段落を丸ごと抽出するマクロ

コメント

  • 2. Re:蛍光ペンのテキスト抽出
    emonさん、

    コメントをどうもありがとうございます。

    こちらの記事につくってみました。
    お試しください。

    http://ameblo.jp/gidgeerock/entry-11086639176.html

    新田順也☆ワードプログラマー返信する

  • 1. 蛍光ペンのテキスト抽出
    このマクロで蛍光ペンの色を指定する（特定の色だけを抽出する）ことはできますか?
    emon

-コード
-, ,