【Word VBA】Wordのスタイルまでタグ化してしまうWordマクロ

Wordのスタイルをタグ化するマクロです！

以前から、Wordの書式のタグ化には興味がありました。

下付き文字の書式情報をタグ化（テキスト情報）に変換するマクロ

文字書式を保存/復元するマクロ

使用中の書式を検出するマクロ

関連して、水野麻子さんが非常に役に立つマクロを公開されています。

このマクロは、マクロ実行前に誤動作を防止する仕組もはいっておりまして、非常に完成度が高くてやさしいマクロです。

【Word】.doc→.txtの悩みを解消

さて、これに関連して、先日おちょこちょいさんから文字書式を保存/復元するマクロ へのコメントをいただきました。

さらに、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