web-dev-qa-db-ja.com

隣接するフォーマットと一致するように空白のフォーマットをインテリジェントに変更しますか？

Microsoft Wordには、フォーマットされたテキストを検索し、それとフォーマットを置き換える機能があります。この機能は、Word文書をオンライン調査に変換する必要がある私の仕事に最適です。簡単な例は、boldの単語を見つけて、それを_<strong>bold</strong>_に置き換えることです。

ただし、受け取ったドキュメントのフォーマットの間に、フォーマットされていない無関係な空白がある場合があります。これにより、すべての太字のテキストを見つけて置き換えるプロセスが少し難しくなります。また、空白には、すべきでないときにフォーマットが適用される場合があります。

正しくフォーマットされていない空白を正しくフォーマットされた空白ですべての空白を見つけて置き換えるためのマクロ、またはワイルドカード（正規表現）検索/置換とは何ですか？

「正しくない」の2つの基準は、行の最後の空白がフォーマットされていないことと、2つのフォーマットされた単語の間の空白がフォーマットされている必要があることです。基本的に、私はcleanestReplace Allpossibleを作成しようとしています。

次のスクリーンショットを例として取り上げます。

screenshot

ピンク/紫のハイライトは、通常のスタイルの空白を表しますが、イタリック体にする必要があります。

赤/オレンジのハイライトは、太字の空白を表しますが、通常の太字ではないスタイルである必要があります。

どちらの場合も、一方をイタリックに変換し、もう一方から太字のスタイルを完全に削除するために、マクロまたはワイルドカードの検索/置換が必要になります。

さらに詳しく説明するには：

現在、Microsoft Wordのフォントスタイル形式のみを使用してすべてを検索して置換すると、一部の行に3つの_<em>_要素が表示されます。例：

<em>The average American expects the rate of deflation (opposite</em> <em>of</em> <em>inflation)</em> will be between 0% and 2%

理想的な結果は、1つの_<em>_要素になります。

<em>The average American expects the rate of deflation (opposite of inflation)</em> will be between 0% and 2%

（例として斜体と太字を使用していますが、下線付きのテキストについても同じことが言えます。）

microsoft-wordvbaregexmacrosmicrosoft-word-2010
3
Alexander Dixon

Wordの「ワイルドカード」検索および置換では、（非常に）限定された非標準形式の正規表現が使用されます。フォーマットも検索して置換する必要があるという事実と相まって、組み込みの検索と置換を使用して、ワイルドカードを使用するかどうかに関係なく、必要なことを実行することはできません。

ただし、マクロ内のWordの検索/置換を利用してインテリジェントな空白変換を実行することは可能です。 Wordの検索/置換にアクセスせずに、VBAで使用可能な適切な正規表現のみを使用してマクロを作成することもできます。

次のソリューションは前者を実行し、Findオブジェクトを使用して、ワイルドカードを使用せずにWordの検索/置換をプログラムで実行します。ただし、いくつかのヘルパー関数でVBA（またはより厳密にはVBScript）の正規表現を使用して、それらを単純化します。

空白を適切に変換するだけでなく、すべてのステップをさらに検索して置き換える必要がありますが、スクリプトは空白を効果的に変換しますand HTMLの折り返しとフォーマットの削除をすべて同時に行います。

'============================================================================================
' Module     : <in any standard module>
' Version    : 0.1.4
' Part       : 1 of 1
' References : Microsoft VBScript Regular Expressions 5.5   [VBScript_RegExp_55]
' Source     : https://superuser.com/a/1321448/763880
'============================================================================================
Option Explicit

Private Const s_BoldReplacement = "<strong>^&</strong>"
Private Const s_ItalicReplacement = "<em>^&</em>"
Private Const s_UnderlineReplacement = "<u>^&</u>"

Private Enum FormatType
  Bold
  Italic
  Underline
End Enum

Public Sub ConvertFormattedTextToHTML()

  With Application
    .ScreenUpdating = True ' Set to False to speed up execution for large documents
    ConvertTextToHTMLIf Bold
    ConvertTextToHTMLIf Italic
    ConvertTextToHTMLIf Underline
    .ScreenUpdating = True
  End With

End Sub

Private Sub ConvertTextToHTMLIf _
            ( _
                       ByVal peFormatType As FormatType _
            )

  ' Create/setup a Find object
  Dim rngFound As Range: Set rngFound = ActiveDocument.Content
  With rngFound.Find
    .MatchCase = True ' Required, otherwise an all-caps found chunk's replacement is converted to all-caps
    .Format = True
    Select Case peFormatType
      Case FormatType.Bold:
        .Font.Bold = True
        .Replacement.Font.Bold = False
        .Replacement.Text = s_BoldReplacement
      Case FormatType.Italic:
        .Font.Italic = True
        .Replacement.Font.Italic = False
        .Replacement.Text = s_ItalicReplacement
      Case FormatType.Underline:
        .Font.Underline = True
        .Replacement.Font.Underline = False
        .Replacement.Text = s_UnderlineReplacement
    End Select
  End With

  ' Main "chunk" loop:
  ' - Finds the next chunk (contiguous appropriately formatted text);
  ' - Expands it to encompass the following chunks if only separated by unformatted grey-space (white-space + punctuation - vbCr - VbLf)
  ' - Removes (and unformats) leading and trailing formatted grey-space from the expanded-chunk
  ' - Converts the trimmed expanded-chunk to unformatted HTML
  Do While rngFound.Find.Execute() ' (rngFound is updated to the "current" chunk if the find succeeds)
    If rngFound.End = rngFound.Start Then Exit Do ' ## bug-workaround (Bug#2 - see end of sub) ##
    ' Create a duplicate range in order to track the endpoints for the current chunk's expansion
    Dim rngExpanded As Range: Set rngExpanded = rngFound.Duplicate
    rngFound.Collapse wdCollapseEnd ' ## bug-workaround (Bug#2 - see end of sub) ##
    ' Expansion loop
    Do
      ' If more chunks exist ~> the current chunk is fully expanded
      If Not rngFound.Find.Execute() Then Exit Do ' (rngFound is updated to the next chunk if the find succeeds)
      If rngFound.End = rngFound.Start Then Exit Do ' ## bug-workaround (Bug#2 - see end of sub) ##
      ' If the formatting continues across a line boundary ~> terminate the current chunk at the boundary
      If rngFound.Start = rngExpanded.End And rngExpanded.Characters.Last.Text = vbCr Then Exit Do ' ## requiring the vbCr check is a bug-workaround (Bug#1 - see end of sub) ##
      ' If the intervening (unformatted) text doesn't just consist of grey-space ~> the current chunk is fully expanded
      ' (Note that since vbCr & vbLf aren't counted as grey-space, chunks don't expand across line boundaries)
      If NotJustGreySpace(rngFound.Parent.Range(rngExpanded.End, rngFound.Start)) Then Exit Do
      ' Otherwise, expand the current chunk to encompass the inter-chunk (unformatted) grey-space and the next chunk
      rngExpanded.SetRange rngExpanded.Start, rngFound.End
      rngFound.Collapse wdCollapseEnd ' ## bug-workaround (Bug#2 - see end of sub) ##
    Loop
    With rngExpanded.Font
      ' Clear the appropriate format for the expanded-chunk
      Select Case peFormatType
        Case FormatType.Bold:           .Bold = False
        Case FormatType.Italic:       .Italic = False
        Case FormatType.Underline: .Underline = False
      End Select
    End With
    With TrimRange(rngExpanded) ' (rngExpanded also gets updated as a side-effect)
      With .Font
        ' Restore the appropriate format for the trimmed expanded-chunk
        Select Case peFormatType
          Case FormatType.Bold:           .Bold = True
          Case FormatType.Italic:       .Italic = True
          Case FormatType.Underline: .Underline = True
        End Select
        ' (Leading and trailing grey-space is now unformatted wrt the appropriate format)
      End With
      ' Unformat the trimmed expanded-chunk and convert it to HTML
      If .Start = .End _
      Then ' ~~ Grey-space Only ~~
        ' Don't convert. (Has already been unformatted by the previous trim)
      Else ' ~~ Valid Text ~~
        ' Need to copy the trimmed expanded-chunk endpoints back to rngFound as we can't use rngExpanded for the replace
        ' since a duplicate's Find object gets reset upon duplication.
        rngFound.SetRange .Start, .Start ' ## Second .Start instead of .End is a bug-workaround (Bug#2 - see below) ##
        rngFound.Find.Text = rngExpanded.Text ' ## bug-workaround (Bug#2 - see end of sub) ##
        rngFound.Find.Execute Replace:=wdReplaceOne
        rngFound.Find.Text = vbNullString ' ## bug-workaround (Bug#2 - see end of sub) ##
      End If
      rngFound.Collapse wdCollapseStart ' ## bug-workaround (Bug#1 & Bug#2 - see end of sub) ##
    End With
  Loop

  ' ## Bug#1 ## Normally, after a range has been updated as a result of performing the Execute() method to *find*
  ' something, performing a second "find" will continue the search in the rest of the document. If, however, the range
  ' is modified in such a way that the same find would not succeed in the range (as is what typically happens when using
  ' Execute() to perform a find/replace), then a second "find" will *NOT* continue the search in the rest of the
  ' document and fails instead. The solution is to "collapse" the range to zero width. See the following for more info:
  ' http://web.archive.org/web/20180512034406/https://gregmaxey.com/Word_tip_pages/words_fickle_vba_find_property.html

  ' ## Bug#2 ## Good ol' buggy Word sometimes decides to split a chunk up even though it doesn't cross a line boundary.
  ' Also, even when the Find object's wrap property is set to wdFindStop (default value), it sometimes behaves as if the
  ' property is set to wdFindContinue, which is also buggy, resulting in Execute() not returning False when no more
  ' chunks exist after wrapping (and *correctly* not updating rngFound). This requires a few work-arounds to cater for
  ' all the resulting combination of Edge cases.
  ' See the following for a example doc reproducing this bug:
  ' https://drive.google.com/open?id=11Z9fpxllk2ZHAU90_lTedhYSixQQucZ5
  ' See the following for more details on when this occurs:
  ' https://chat.stackexchange.com/rooms/77370/conversation/Word-bug-finding-formats-in-line-before-table

End Sub

' Note that vbCr & vbLf are NOT treated as white-space.
' Also note that "GreySpace" is used to indicate it is not purely white-space, but also includes punctuation.
Private Function IsJustGreySpace _
                 ( _
                            ByVal TheRange As Range _
                 ) _
        As Boolean

  Static rexJustWhiteSpaceExCrLfOrPunctuation As Object '## early binding:- As VBScript_RegExp_55.RegExp
  If rexJustWhiteSpaceExCrLfOrPunctuation Is Nothing Then
    Set rexJustWhiteSpaceExCrLfOrPunctuation = CreateObject("VBScript.RegExp") ' ## early binding:- = New VBScript_RegExp_55.RegExp
    rexJustWhiteSpaceExCrLfOrPunctuation.Pattern = "^(?![^\r\n]*?[\r\n].*$)[\s?!.,:;-]*$" ' ## the last * instead of + is a bug-workaround (Bug#2 - see end of main sub) ##
  End If

  IsJustGreySpace = rexJustWhiteSpaceExCrLfOrPunctuation.test(TheRange.Text)

End Function

Private Function NotJustGreySpace _
                 ( _
                            ByVal TheRange As Range _
                 ) _
        As Boolean

  NotJustGreySpace = Not IsJustGreySpace(TheRange)

End Function

Private Function TrimRange _
                 ( _
                            ByRef TheRange As Range _
                 ) _
        As Range

  Static rexTrim As Object '## early binding:- As VBScript_RegExp_55.RegExp
  If rexTrim Is Nothing Then
    Set rexTrim = CreateObject("VBScript.RegExp") ' ## early binding:- = New VBScript_RegExp_55.RegExp
    rexTrim.Pattern = "(^[\s?!.,:;-]*)(.*?)([\s?!.,:;-]*$)"
  End If

  With rexTrim.Execute(TheRange.Text)(0)
    If Len(.SubMatches(1)) = 0 _
    Then ' ~~ Grey-space Only ~~
      TheRange.Collapse wdCollapseEnd
    Else
      TheRange.SetRange TheRange.Start + Len(.SubMatches(0)), TheRange.End - Len(.SubMatches(2))
    End If
  End With
  Set TrimRange = TheRange

End Function

基準：

私は、空白変換の基準を少し拡張/外挿する自由を取りました。これらは、正確な要件を満たしていない場合は変更できます。現在、それらは次のとおりです。

  1. 変換は、個々のフォーマットタイプごとに個別に行われます。つまり、太字、斜体、下線です。現在、スクリプトはこれら3つのタイプのみを処理します。タイプは簡単に追加/削除できます。
  2. 変換は行ごとに行われます。線の境界を越えることはありません。これは、キャリッジリターン文字と改行文字を空白以外の文字として扱い、Wordの組み込み検索を利用して行境界で検索を終了した結果です。
  3. コメントのリクエストに続いて、句読文字?!.,:;-は空白と同じように扱われるようになりました。
  4. 連続する空白/句読点のシーケンスで、シーケンスの前にある非空白/句読点の文字が、シーケンスに続く文字と同じフォーマットである場合、そのフォーマットに変換されます。これにより、フォーマットされていない単語間の空白/句読点からフォーマットが削除され、フォーマットされていない空白/句読点を含むようにフォーマットされたテキストが「拡張」されることに注意してください。
  5. 連続する空白/句読点のシーケンスの前後の文字フォーマットが異なる場合、空白/句読点のシーケンスは強制的にフォーマットされません。行ごとの変換と組み合わせると、次のようになります。
    1. 書式設定されていない行の先頭または末尾の空白/句読点。
    2. 書式設定されていないテキストのセクションの先頭または末尾の空白/句読点。

注：

  • スクリプトはかなりよく文書化されているので、自明である必要があります。

  • 遅延バインディングを使用するため、参照を設定する必要はありません。

編集：コメントに従って新しいバージョンで更新されました。

2
robinCTS