サンプルコードでできること
- 本文、ヘッダー・フッター、脚注、オートシェイプの蛍光マーカーの文字列を抽出。別文書にリストを作成します。
- リストの1列目にページ番号、2列目に蛍光マーカーの文字列を表示します。
コードの説明
本文、オートシェイプ、脚注、文末脚注、ヘッダー・フッターの順に蛍光マーカーを検索。
変数に蛍光マーカーのページ番号と文字列を格納。
ヘッダー・フッターと文末脚注は別リストにするため、3つの変数を用意。
・mkrList（本文・脚注、オートシェイプ用）
・hfMkrList（ヘッダー・フッター用）
・endNoteMkrList（文末脚注用）
リストを分ける理由
- ヘッダー・フッターのページ番号は、蛍光マーカーが表示される全ページではなく、セクションの最初のページのみ取得。他のページ番号と異なるため。
- 文末脚注は蛍光マーカーの文字列があるページではなく、脚注番号のあるページを表示しているため、注意事項を表示する必要があるため。
文末脚注のページ番号取得が難しい理由
通常であれば「Selection.Range.Information(wdActiveEndPageNumber)」で、選択位置のページ番号を取得できます。
文末脚注の場合、脚注文字列を選択しても、脚注番号のあるページ番号を取得されるのです。
たとえば、1ページに脚注番号、5ページに文末脚注の文字列がある場合、「5」が必要なのに、取得できるのは「1」です。
下記のコードで、脚注番号のセクションの最後のページを取得できます。
文末脚注を「セクションの最後」に表示する設定は、このコードでOKです。
mkrList = mkrList & ActiveDocument. _ Sections(.Information(wdActiveEndSectionNumber)) _ .Range.Paragraphs.Last.Range.Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf
「文書の最後」に表示する設定のコードも必要で複雑になるため、脚注番号のページを表示して、コメントを入れることにしました。
ヘッダー・フッターの蛍光マーカーは、「前と同じヘッダー/フッター」がオフの場合のみ文字列を抽出します。
たとえば、セクション1のヘッダーに蛍光マーカーが含まれていて、セクション2、3の「前と同じヘッダー/フッター」がオンの場合、セクション1の蛍光マーカーのみ抽出します。
本文の蛍光マーカーのページ番号と文字列の格納は、前回の記事と同じです。
rapoppo.hatenadiary.jp
If hdr.LinkToPrevious = False Then
「前と同じヘッダー/フッター」がオフの場合のみ、蛍光マーカーを検索しています。
Sub GetMarkerList() '蛍光マーカー（ハイライト）の一覧を別文書に作成します。 Dim rng As Range, dcNew As Document Dim sec As Section, hdr As HeaderFooter, ftr As HeaderFooter Dim mkrList As String, hfMkrList As String, endNoteMkrList As String Dim spMkrList As String, shp As Shape, gShp As Shape Dim i As Long, b As Boolean Set rng = ActiveDocument.Range(0, 0) With rng .Find.Highlight = True Do While .Find.Execute = True And .Text <> "" mkrList = mkrList & rng.Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf .SetRange .End, .End Loop End With 'オートシェイプ検索 For Each shp In ActiveDocument.Shapes 'グループ化の場合 If shp.Type = msoGroup Then For Each gShp In shp.GroupItems If gShp.TextFrame.HasText Then With gShp.TextFrame.TextRange .Find.Highlight = True Do While .Find.Execute = True And .Text <> "" mkrList = mkrList & .Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf .SetRange .End, .End Loop End With End If Next End If If shp.TextFrame.HasText Then Set rng = shp.TextFrame.TextRange With rng .Find.Highlight = True Do While .Find.Execute = True And .Text <> "" mkrList = mkrList & .Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf .SetRange .End, .End Loop End With End If Next '脚注検索 If ActiveDocument.Footnotes.Count > 0 Then ActiveDocument.Footnotes(1).Range.Select Selection.Collapse Set rng = Selection.Range '脚注の先頭位置を格納 With rng .Find.Highlight = True Do While .Find.Execute = True And .Text <> "" mkrList = mkrList & .Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf .SetRange .End, .End Loop End With End If '文末脚注検索 If ActiveDocument.Endnotes.Count > 0 Then ActiveDocument.Endnotes(1).Range.Select Selection.Collapse Set rng = Selection.Range With rng .Find.Highlight = True Do While .Find.Execute = True And .Text <> "" endNoteMkrList = endNoteMkrList & .Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf .SetRange .End, .End Loop End With End If 'ヘッダーフッター検索 For Each sec In ActiveDocument.Sections For Each hdr In sec.Headers If hdr.LinkToPrevious = False Then With hdr.Range .Find.Highlight = True Do While .Find.Execute = True And .Text <> "" hfMkrList = hfMkrList & .Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf .SetRange .End, .End Loop End With End If Next For Each ftr In sec.Footers If ftr.LinkToPrevious = False Then With ftr.Range .Find.Highlight = True Do While .Find.Execute = True And .Text <> "" hfMkrList = hfMkrList & .Information(wdActiveEndPageNumber) _ & vbTab & .Text & vbCrLf .SetRange .End, .End Loop End With End If Next Next If mkrList = "" And hfMkrList = "" And endNoteMkrList = "" Then MsgBox "ハイライトはありませんでした。" Exit Sub End If Set dcNew = Documents.Add With dcNew.PageSetup .TopMargin = MillimetersToPoints(30) .BottomMargin = MillimetersToPoints(30) .LeftMargin = MillimetersToPoints(30) .RightMargin = MillimetersToPoints(30) End With If mkrList <> "" Then dcNew.Range(0, 0).InsertAfter mkrList With Selection .WholeStory SelTextConvertToTable Selection '選択テキストを表に変換 SetTblStyle .Tables(1) '表スタイルを適用して列調整 '並び替え .Sort ExcludeHeader:=False, _ FieldNumber:="列 1", _ SortFieldType:=wdSortFieldNumeric, _ SortOrder:=wdSortOrderAscending .EndKey wdStory '文書末に移動 End With End If If hfMkrList <> "" Then With Selection .TypeParagraph .InsertAfter "ヘッダー・フッター" .Collapse wdCollapseEnd .TypeParagraph .InsertAfter hfMkrList SelTextConvertToTable Selection '選択テキストを表に変換 SetTblStyle .Tables(1) '表スタイルを適用して列調整 End With End If Selection.EndKey wdStory '文書末に移動 If endNoteMkrList <> "" Then With Selection .TypeParagraph .InsertAfter "文末脚注" & vbCrLf & _ "※表の1列目は脚注番号のページです。" & _ "番号をダブルクリックして、文末脚注のページへ移動してください。" .Paragraphs(2).Range.Font.Size = 8 .Collapse wdCollapseEnd .Font.Size = 10.5 .TypeParagraph .InsertAfter endNoteMkrList SelTextConvertToTable Selection '選択テキストを表に変換 SetTblStyle .Tables(1) '表スタイルを適用して列調整 End With End If End Sub Private Sub SetTblStyle(tbl As Table) '選択した表に表 (格子)スタイルを適用して、列幅を調整します With tbl .Style = "表 (格子)" .ApplyStyleHeadingRows = True .PreferredWidthType = wdPreferredWidthPercent .PreferredWidth = 100 .Columns(1).PreferredWidth = 10 .Columns(2).PreferredWidth = 90 End With End Sub Private Sub SelTextConvertToTable(sel As Selection) '選択したテキストを表に変換します。 '一行挿入して、タイトルを入力します。 With sel .ConvertToTable Separator:=wdSeparateByTabs .InsertRowsAbove 1 .TypeText Text:="ページ" .MoveRight Unit:=wdCell .TypeText Text:="ハイライト" End With End Sub
