2018年4月23日追記 【コード】文字書式を保存/復元するWordマクロ（その2）に改良版を掲載
太字、下付き、上付きなど、文字の書式が設定されている文章をテキストエディターで編集したいときありませんか？
通常、この文章をテキストエディタにコピーすると、書式がすべてなくなってしまいますね。
そんな悩みを解決するマクロです。
前回のこちらの記事 の応用版です。
用途
ウェブやワードの文章をテキストエディタで編集する場合に、必要最小限の文字書式を保持できます。
編集が終わった後、ワードにコピーしたテキスト情報にもとの文字書式を復元します。
作用
文字書式が含まれる文書を用意します。
①文字書式をhtmlで使われるタグに変換します。（プログラム１）
②タグを書式に戻します。（プログラム２）
保持できる文字書式
以下の６種類です。各プログラムの１０行～６０行に定義しました。
下付き
上付き
太字
斜体
下線（一重線）
取り消し線
工夫
プログラム１の22行～24行に、フィールドやリンクの設定を解除するコードを挿入しました。
ウェブから文章をコピーした場合に、なんらかの情報が文字に組み込まれていると、タグ化が正常に作動しない場合があります。
これを回避するために、文字に組み込まれた情報をまず削除してからタグ化をしています。
登録方法
以下のページをご覧ください。
○ ワードマクロの作成(ver.95～2003）
○ ワードマクロの作成(ver.2007）
○ マクロにショートカットを割り当てる
プログラム１ 書式をテキスト情報（タグ）に変換
Sub 文字書式をタグ化() 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" 'フィールドのリンク削除（太字の無限ループに入ることがあるから） For Each aField In ActiveDocument.Fields aField.Unlink Next aField '書式のタグ化 For i = 1 To 6 Set myRange = ActiveDocument.Range(0, 0) With myRange.Find .Wrap = wdFindStop If i = 1 Then .Font.Subscript = True ElseIf i = 2 Then .Font.Superscript = True ElseIf i = 3 Then .Font.Bold = True ElseIf i = 4 Then .Font.Italic = True ElseIf i = 5 Then .Font.Underline = wdUnderlineSingle ElseIf i = 6 Then .Font.StrikeThrough = True End If .Execute findText:="" End With Do While myRange.Find.Found = True With myRange If i = 1 Then .Font.Subscript = False ElseIf i = 2 Then .Font.Superscript = False ElseIf i = 3 Then .Font.Bold = False ElseIf i = 4 Then .Font.Italic = False ElseIf i = 5 Then .Font.Underline = wdUnderlineNone ElseIf i = 6 Then .Font.StrikeThrough = False End If End With With Selection.Range .SetRange Start:=myRange.End, End:=myRange.End .Text = "</" & myChr(i) & ">" .SetRange Start:=myRange.Start, End:=myRange.Start .Text = "<" & myChr(i) & ">" End With myRange.Collapse myRange.Find.Execute Loop Next Set myRange = Nothing End Sub
プログラム２ テキスト情報（タグ）を書式に変換
Sub 文字書式の復元() Dim myRange 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" For i = 1 To 6 Set myRange = ActiveDocument.Range(0, 0) With myRange.Find .Wrap = wdFindStop .MatchWildcards = True .Execute findText:="[<]" & myChr(i) & "[>]*[<][/]" & myChr(i) & "[>]" End With Do While myRange.Find.Found = True With myRange If i = 1 Then .Font.Subscript = True ElseIf i = 2 Then .Font.Superscript = True ElseIf i = 3 Then .Font.Bold = True ElseIf i = 4 Then .Font.Italic = True ElseIf i = 5 Then .Font.Underline = wdUnderlineSingle ElseIf i = 6 Then .Font.StrikeThrough = True End If End With With Selection.Range .SetRange Start:=myRange.End, End:=myRange.End - Len(myChr(i)) - 3 .Delete .SetRange Start:=myRange.Start, End:=myRange.Start + Len(myChr(i)) + 2 .Delete End With myRange.Collapse myRange.Find.Execute Loop Next Set myRange = Nothing End Sub
いただいたコメント
1. このマクロは便利ですね
こんにちは。
タグを付けるマクロは、とても便利なのですよね。違う書き方もできますので、あげてみました。
http://ameblo.jp/saglasie/entry-10516628393.html参考まで。
