【コード】文字書式を保存/復元するWordマクロ(その2)

かつて、「【コード】文字書式を保存/復元する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 = nothiong
 
End Sub

トップへ戻る