【Word VBA】文字書式を保存/復元するWordマクロ（その2）

2022/10/22 コード 0
, , ,

かつて、「【コード】文字書式を保存/復元するWordマクロ」という記事を書きましたが、今なら別の書き方をするなーと感じたので書き直しました。

このマクロでできること

1つ目のマクロで下付き、上付き、太字、斜体、下線（一重線）、取り消し線の書式をタグ化します。

2つ目のマクロでタグ化した箇所に書式を設定します。

（タグ化実行前）

（タグ化実行後）

上記のタグを元に復元もできます。

マクロの解説

以前の記事では、せっかくRangeオブジェクトを使ってカーソル移動を防いでいるにもかかわらずタグ入力はSelectionオブジェクトを用いてカーソルが移動してしまっています。

このようなことにならないように、すべてRangeオブジェクトで処理をするようにしました。

また、タグの文字列を入力する際に文字入力箇所を指定してText プロパティを使っていますが変更しました。

ここは、Range.InsertAfter メソッドやRange.InsertBefore メソッドを使うべき典型的なパターンだと思います（「文字書式をタグ化2」の63行目、64行目）。

マクロ


Sub 文字書式をタグ化2()

　Dim myDoc As Document
　Dim myRange As Range
　Dim myChr(1 To 6) As String
　Dim i As Integer
　Dim aField As Field
　
　'下付き
　myChr(1) = "sub"
　'上付き
　myChr(2) = "sup"
　'太字
　myChr(3) = "b"
　'斜体
　myChr(4) = "i"
　'下線（一重線）
　myChr(5) = "u"
　'取り消し線
　myChr(6) = "s"
　
　Set myDoc = ActiveDocument
　
　'フィールドのリンク削除（太字の無限ループに入ることがあるから）
　For Each aField In myDoc.Fields
　　aField.Unlink
　Next aField
　
　'書式のタグ化
　For i = 1 To 6
　
　　Set myRange = myDoc.Range(0, 0)
　
　　With myRange.Find
　　　.Text = ""
　　　.Wrap = wdFindStop
　　　.Format = True
　　　.MatchCase = False
　　　.MatchWholeWord = False
　　　.MatchByte = False
　　　.MatchAllWordForms = False
　　　.MatchSoundsLike = False
　　　.MatchFuzzy = False
　　　.MatchWildcards = True
　　　
　　　Select Case myChr(i)
　　　　Case "sub" '下付き
　　　　　.Font.Subscript = True
　　　　Case "sup" '上付き
　　　　　.Font.Superscript = True
　　　　Case "b" '太字
　　　　　.Font.Bold = True
　　　　Case "i" '斜体
　　　　　.Font.Italic = True
　　　　Case "u" '下線（一重線）
　　　　　.Font.Underline = wdUnderlineSingle
　　　　Case "s" '取り消し線
　　　　　.Font.StrikeThrough = True
　　　End Select
　　　
　　　Do While .Execute = True
　　　　With myRange
　　　　　.InsertBefore "<" & myChr(i) & ">"
　　　　　.InsertAfter "</" & myChr(i) & ">"
　　　　　Select Case myChr(i)
　　　　　　Case "sub" '下付き
　　　　　　　.Font.Subscript = False
　　　　　　Case "sup" '上付き
　　　　　　　.Font.Superscript = False
　　　　　　Case "b" '太字
　　　　　　　.Font.Bold = False
　　　　　　Case "i" '斜体
　　　　　　　.Font.Italic = False
　　　　　　Case "u" '下線（一重線）
　　　　　　　.Font.Underline = wdUnderlineNone
　　　　　　Case "s" '取り消し線
　　　　　　　.Font.StrikeThrough = False
　　　　　End Select
　　　　　.Collapse wdCollapseEnd
　　　　End With
　　　Loop
　　　
　　End With
　
　Next
　
　Set myDoc = Nothing
　Set myRange = Nothing
　
End Sub

 


Sub 文字書式の復元2()

　Dim myDoc As Document
　Dim myRange As Range
　Dim myTempRange As Range
　Dim myChr(1 To 6) As String
　Dim i As Integer

　'下付き
　myChr(1) = "sub"
　'上付き
　myChr(2) = "sup"
　'太字
　myChr(3) = "b"
　'斜体
　myChr(4) = "i"
　'下線（一重線）
　myChr(5) = "u"
　'取り消し線
　myChr(6) = "s"

　Set myDoc = ActiveDocument
　
　For i = 1 To 6
　
　　Set myRange = myDoc.Range(0, 0)
　
　　With myRange.Find
　　　.Text = "\<" & myChr(i) & "\>*\</" & myChr(i) & "\>"
　　　.Wrap = wdFindStop
　　　.Format = True
　　　.MatchCase = False
　　　.MatchWholeWord = False
　　　.MatchByte = False
　　　.MatchAllWordForms = False
　　　.MatchSoundsLike = False
　　　.MatchFuzzy = False
　　　.MatchWildcards = True
　　
　　　Do While .Execute = True
　　　
　　　　With myRange
　　　　　Select Case myChr(i)
　　　　　　Case "sub" '下付き
　　　　　　　.Font.Subscript = True
　　　　　　Case "sup" '上付き
　　　　　　　.Font.Superscript = True
　　　　　　Case "b" '太字
　　　　　　　.Font.Bold = True
　　　　　　Case "i" '斜体
　　　　　　　.Font.Italic = True
　　　　　　Case "u" '下線（一重線）
　　　　　　　.Font.Underline = wdUnderlineSingle
　　　　　　Case "s" '取り消し線
　　　　　　　.Font.StrikeThrough = True
　　　　　End Select
　　　　　
　　　　　'末尾のタグを削除
　　　　　Set myTempRange = myDoc.Range(.End - Len(myChr(i)) - 3, .End)
　　　　　myTempRange.Delete
　　　　　
　　　　　'先頭のタグを削除
　　　　　Set myTempRange = myDoc.Range(.Start, .Start + Len(myChr(i)) + 2)
　　　　　myTempRange.Delete
　　　　　
　　　　　.Collapse wdCollapseEnd
　　　　End With
　　　Loop
　　
　　End With

　Next

　Set myDoc = Nothing
　Set myRange = Nothing
　Set myTempRange = nothing
　
End Sub
トップへ戻る