【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

トップへ戻る