« カーソル位置より前に同じ文字列が記載されているか調べるマクロ | トップページ | テンプレートの編集マクロ »

2010年4月24日 (土)

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

太字、下付き、上付きなど、文字の書式が設定されている文章を
テキストエディターで編集したいときありませんか?

通常、この文章をテキストエディタにコピーすると、書式がすべて
なくなってしまいますね。

そんな悩みを解決するマクロです。

▼用途
ウェブやワードの文章をテキストエディタで編集する場合に、
必要最小限の文字書式を保持できます。

編集が終わった後、ワードにコピーしたテキスト情報にもとの
文字書式を復元します。

▼作用
①これらの書式をhtmlで使われるタグに変換します。(プログラム1)
②テキストエディターで編集
③タグを書式に戻します。(プログラム2)

▼保持できる文字書式
以下の6種類です。各プログラムの10行~60行に定義しました。

下付き
上付き
太字
斜体
下線(一重線)
取り消し線

▼工夫
プログラム1の70行~90行に、フィールドやリンクの設定を
解除するコードを挿入しました。

ウェブから文章をコピーした場合に、なんらかの情報が文字に
組み込まれていると、タグ化が正常に作動しない場合があります。

これを回避するために、文字に組み込まれた情報をまず削除してから
タグ化をしています。

以前こちらで紹介したマクロの改良版です。

▼プログラム1 書式をテキスト情報(タグ)に変換

Sub 文字書式をタグ化()
         
      Dim myRange As Range
      Dim myChr(1 To 6) As String
      Dim i As Integer
      Dim aField As Field

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

      'フィールドのリンク削除(太字の無限ループに入ることがあるから)
70    For Each aField In ActiveDocument.Fields
80        aField.Unlink
90    Next aField

      '書式のタグ化
100   For i = 1 To 6
110       Set myRange = ActiveDocument.Range(0, 0)

120       With myRange.Find
130          .Wrap = wdFindStop
140           If i = 1 Then
150               .Font.Subscript = True
160           ElseIf i = 2 Then
170               .Font.Superscript = True
180           ElseIf i = 3 Then
190               .Font.Bold = True
200           ElseIf i = 4 Then
210               .Font.Italic = True
220           ElseIf i = 5 Then
230               .Font.Underline = wdUnderlineSingle
240           ElseIf i = 6 Then
250               .Font.StrikeThrough = True
260           End If
270          .Execute findText:=""
280       End With
         
290       Do While myRange.Find.Found = True
300           With myRange
310               If i = 1 Then
320                   .Font.Subscript = False
330               ElseIf i = 2 Then
340                   .Font.Superscript = False
350               ElseIf i = 3 Then
360                   .Font.Bold = False
370               ElseIf i = 4 Then
380                   .Font.Italic = False
390               ElseIf i = 5 Then
400                   .Font.Underline = wdUnderlineNone
410               ElseIf i = 6 Then
420                   .Font.StrikeThrough = False
430               End If
440           End With
             
450           With Selection.Range
460               .SetRange Start:=myRange.End, End:=myRange.End
470               .Text = "</" & myChr(i) & ">"
480               .SetRange Start:=myRange.Start, End:=myRange.Start
490               .Text = "<" & myChr(i) & ">"
500           End With
             
510           myRange.Collapse
520           myRange.Find.Execute
530       Loop
         
540   Next

550   Set myRange = Nothing

End Sub

▼プログラム2 テキスト情報(タグ)を書式に変換

Sub 文字書式の復元()
         
      Dim myRange As Range
      Dim myChr(1 To 6) As String
      Dim i As Integer

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

70    For i = 1 To 6
80        Set myRange = ActiveDocument.Range(0, 0)

90        With myRange.Find
100          .Wrap = wdFindStop
110          .MatchWildcards = True
120          .Execute findText:="[<]" & myChr(i) & "[>]*[<][/]" & myChr(i) & "[>]"
130       End With
         
140       Do While myRange.Find.Found = True
150           With myRange
160               If i = 1 Then
170                   .Font.Subscript = True
180               ElseIf i = 2 Then
190                   .Font.Superscript = True
200               ElseIf i = 3 Then
210                   .Font.Bold = True
220               ElseIf i = 4 Then
230                   .Font.Italic = True
240               ElseIf i = 5 Then
250                   .Font.Underline = wdUnderlineSingle
260               ElseIf i = 6 Then
270                   .Font.StrikeThrough = True
280               End If
290           End With
             
300           With Selection.Range
310               .SetRange Start:=myRange.End, End:=myRange.End - Len(myChr(i)) - 3
320               .Delete
330               .SetRange Start:=myRange.Start, End:=myRange.Start + Len(myChr(i)) + 2
340               .Delete
350           End With
             
360           myRange.Collapse
370           myRange.Find.Execute
380       Loop

390   Next

400   Set myRange = Nothing

End Sub

|

« カーソル位置より前に同じ文字列が記載されているか調べるマクロ | トップページ | テンプレートの編集マクロ »

マクロプログラム」カテゴリの記事

コメント

コメントを書く



(ウェブ上には掲載しません)




トラックバック

この記事のトラックバックURL:
http://app.cocolog-nifty.com/t/trackback/519619/48166629

この記事へのトラックバック一覧です: 文字書式を保存/復元するマクロ:

« カーソル位置より前に同じ文字列が記載されているか調べるマクロ | トップページ | テンプレートの編集マクロ »