カスタム検索
Office関連

 

トップページ > Office関連 > 文字書式をマークアップする(Word VBA)

 

Sponsored Links

文字書式をマークアップする(Word VBA)

太字、上付き、下付きなどの装飾が施された文章をマークアップしてテキスト情報に変換、また変換したテキスト情報から元の通り文章を修飾するマクロです。
あくまでも簡易的なもので、文章からHTMLコードを生成するものではありません。
「文字書式を保存/復元するマクロ」参照(さらに下記コードの改良版がコチラ)。

 

Option Explicit

Public Sub Sample()
'個別に処理
  'StyleToTag "b"
  'StyleToTag "i"
  'StyleToTag "u"
  'StyleToTag "s"
  'StyleToTag "ds"
  'StyleToTag "sup"
  'StyleToTag "sub"
  'StyleToTag "h1"
  'StyleToTag "p"
  
  'TagToStyle "b"
  'TagToStyle "i"
  'TagToStyle "u"
  'TagToStyle "s"
  'TagToStyle "ds"
  'TagToStyle "sup"
  'TagToStyle "sub"
  'TagToStyle "h1"
  'TagToStyle "p"
End Sub

Public Sub Sample_StyleToTag()
'ループでまとめて処理(タグ化)
  Dim s(1 To 9) As String
  Dim i As Long
  
  s(1) = "b"
  s(2) = "i"
  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) = "b"
  s(2) = "i"
  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
  
  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
        r.Text = Replace(r.Text, vbCr, vbNullString)
        r.Text = "<" & sTag & ">" & r.Text & "</" & sTag & ">" & vbCr
      Else
        r.Text = "<" & sTag & ">" & r.Text & "</" & 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
  Set r = Nothing
  Selection.HomeKey Unit:=wdStory
End Sub

Private Sub TagToStyle(ByVal sTag As String)
'タグを装飾化
  Dim r As Word.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
  Set r = Nothing
  Selection.HomeKey Unit:=wdStory
End Sub

 

トップページ > Office関連 > 文字書式をマークアップする(Word VBA)