Wordのスタイルをタグ化するマクロです!
以前から、Wordの書式のタグ化には興味がありました。
下付き文字の書式情報をタグ化(テキスト情報)に変換するマクロ
関連して、水野麻子さんが非常に役に立つマクロを公開されています。
このマクロは、マクロ実行前に誤動作を防止する仕組もはいっておりまして、非常に完成度が高くてやさしいマクロです。
さて、これに関連して、先日おちょこちょいさんから文字書式を保存/復元するマクロ へのコメントをいただきました。
さらに、kinuasaさんがこれに対応して文字書式をマークアップする(Word VBA) の記事にてコード化をしていただいたおかげで、新しいマクロが生まれました。
kinuasaさんのコードを是非ご覧ください。
すごく美しいです。
「StyleToTag」のコードのCase で分類された書き方や、モジュール化の方法など、ヒントが満載です。
この解説だけで記事が何本か書けそうなくらいうれしいコードです。
公開をどうもありがとうございます。
また、私のコードで欠けていた改行記号の書式の処理を追記していただいております。
タグ化の肝は、改行記号にはいっている書式をどうやって処理するか?ですね。
なので、Rangeオブジェクト(以下のコード中の r )に改行記号がある場合とない場合とで処理を分けています。
ときおり、不可解な処理結果になることは知っておりましたが、細かく検証をしておりませんでした。
上記の改行記号の処理の追加で、処理が安定しました。ありがとうございました。
さらに、勝手ながらkinuasaさんのコードを少し改良して、私なりのマクロを作りました。
以下のコード中、部分的に変更しました。それ以外は、kinuasaさんのコードです。
改良点①
文字書式が部分的に重なって登録されている文字列にたいしてタグ化できるように、「StyleToTag」のコードを変更いたしました。
kinuasaさんのコードでは、r.Textを持ちて置き換えをされていますが、r.Textの場合には、書式が落ちることもあるらしいため、別の方法でタグの追記をしました。
まだ、十分に試運転がされていないので、暫定的にこの処理としておきます。
改良点②
おちょこちょいさんのご要望のとおり、斜体と太字とのタグの順序を入れ替えました。
改良点③
先日kinuasaさんから教えていただいたカーソル位置の保存方法を用いました。
StyleToTagとTagToStyleの両方のコードで、myRangeというオブジェクトを定義しています。
ここにカーソル位置を保存しています。
Public Sub Sample_StyleToTag() 'ループでまとめて処理(タグ化) Dim s(1 To 9) As String Dim i As Long s(1) = "i" s(2) = "b" s(3) = "u" s(4) = "s" s(5) = "ds" s(6) = "sup" s(7) = "sub" s(8) = "h1" s(9) = "p" For i = LBound(s) To UBound(s) StyleToTag s(i) Next End Sub Public Sub Sample_TagToStyle() 'ループでまとめて処理(装飾化) Dim s(1 To 9) As String Dim i As Long s(1) = "i" s(2) = "b" s(3) = "u" s(4) = "s" s(5) = "ds" s(6) = "sup" s(7) = "sub" s(8) = "h1" s(9) = "p" For i = LBound(s) To UBound(s) TagToStyle s(i) Next End Sub Private Sub StyleToTag(ByVal sTag As String) '装飾をタグ化 Dim r As word.Range Dim myRange As word.Range Set myRange = Selection.Range Set r = ActiveDocument.Range(0, 0) With r.Find .ClearFormatting .Format = True .Forward = True .MatchWildcards = False .Text = vbNullString '装飾検索(条件設定) Select Case LCase$(sTag) Case "b": .Font.Bold = True '太字 Case "i": .Font.Italic = True '斜体 Case "u": .Font.Underline = wdUnderlineSingle '下線 Case "s": .Font.StrikeThrough = True '取り消し線 Case "ds": .Font.DoubleStrikeThrough = True '二重取り消し線 Case "sup": .Font.Superscript = True '上付き文字 Case "sub": .Font.Subscript = True '下付き文字 Case "h1": .Style = ActiveDocument.Styles("見出し 1") '[見出し 1] Case "p": .Style = ActiveDocument.Styles("本文") '[本文] Case Else MsgBox "対応していない形式です。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal Exit Sub End Select Do While .Execute If InStr(r.Text, vbCr) Then If vbCr <> r.Text Then r.End = r.End - 1 r.InsertBefore "<" & sTag & ">" r.InsertAfter "</" & sTag & ">" Else 'r自体が改行記号の場合→何もしない End If Else r.InsertBefore "<" & sTag & ">" r.InsertAfter "</" & sTag & ">" End If '装飾解除 Select Case LCase$(sTag) Case "b": r.Font.Bold = False Case "i": r.Font.Italic = False Case "u": r.Font.Underline = wdUnderlineNone Case "s": r.Font.StrikeThrough = False Case "ds": r.Font.DoubleStrikeThrough = False Case "sup": r.Font.Superscript = False Case "sub": r.Font.Subscript = False Case "h1", "p": r.Select: Selection.ClearFormatting End Select r.Collapse wdCollapseEnd Loop .ClearFormatting End With myRange.Select Set r = Nothing Set myRange = Nothing End Sub Private Sub TagToStyle(ByVal sTag As String) 'タグを装飾化 Dim r As word.Range Dim myRange As word.Range Set myRange = Selection.Range '対応チェック Select Case LCase$(sTag) Case "b", "i", "u", "s", "ds", "sup", "sub", "h1", "p": Case Else MsgBox "対応していない形式です。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal Exit Sub End Select Set r = ActiveDocument.Range(0, 0) With r.Find .ClearFormatting .Format = False .Forward = True .MatchFuzzy = False .MatchWildcards = True .Text = "\<" & sTag & "\>*\</" & sTag & "\>" Do While .Execute '装飾実施 Select Case LCase$(sTag) Case "b": r.Font.Bold = True Case "i": r.Font.Italic = True Case "u": r.Font.Underline = wdUnderlineSingle Case "s": r.Font.StrikeThrough = True Case "ds": r.Font.DoubleStrikeThrough = True Case "sup": r.Font.Superscript = True Case "sub": r.Font.Subscript = True Case "h1": r.Style = ActiveDocument.Styles("見出し 1") Case "p": r.Style = ActiveDocument.Styles("本文") End Select 'タグ除去 Selection.SetRange r.End - Len(sTag) - 3, r.End Selection.delete Selection.SetRange r.Start, r.Start + Len(sTag) + 2 Selection.delete r.Collapse wdCollapseEnd Loop .ClearFormatting End With myRange.Select Set r = Nothing Set myRange = Nothing End Sub