Блог

Я пытаюсь удалить выделенные символы пробела из текста Word с помощью макроса, но он зависает / зацикливается всякий раз, когда встречает некоторые комментарии или URL-адреса (не все). Как это возможно? И каким будет решение?

 Sub checkforHighlightsOrg()

    Application.ScreenUpdating = False
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True
    regex.Pattern = "^s $" ' highlighted text having multiple white-space/invisible chars only
    
    Selection.Find.ClearFormatting
    Selection.Find.Highlight = True
    With Selection.Find
        .text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
        .Replacement.Highlight = True
        .Replacement.ClearFormatting
    End With
    
    Dim bReplaced As Boolean
    bReplaced = False
    
    Do While Selection.Find.Execute = True
        If Selection.Find.Found Then
             If regex.Test(Selection.text) Then
                bReplaced = True
                Selection.text = regex.Replace(Selection.text, "")
             End If
        End If
        DoEvents
    Loop
    
    If bReplaced Then MsgBox "Highlighted white-spaces have been removed."
    
    Set rngTemp = ActiveDocument.Range

    With rngTemp.Find
        .ClearFormatting
        .Highlight = True
        .Forward = True
        .Execute
    End With
    If rngTemp.Find.Found = True Then
        MsgBox ("There have been non-white-space highlights found.")
    End If
    
    Application.ScreenUpdating = True

End Sub
  

Другая версия, которую я пробовал, выглядит следующим образом:

 Sub checkforHighlightsV2()

    Application.ScreenUpdating = False
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True
    regex.Pattern = "s " ' highlighted text having multiple white-space/invisible chars only
    ActiveDocument.Select
      
    
    Dim regex2 As Object, str As String
    Set regex2 = CreateObject("VBScript.RegExp")
     
    With regex2
      .Pattern = "s"
      .Global = True 'If False, would replace only first
    End With

    
    
    Selection.Find.ClearFormatting
    Selection.Find.Highlight = True
    With Selection.Find
        .text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
        .Replacement.Highlight = True
        .Replacement.ClearFormatting
    End With
    
    Dim bReplaced As Boolean
    bReplaced = False
    Dim a As Range

    
    
    
restart:
    
    Do While Selection.Find.Execute = True
        If Selection.Find.Found Then
    'Selection.MoveEnd wdParagraph, 1
    
     
    Set a = Selection.Range.Duplicate
    'Debug.Print Asc(a.text)
    
    'a.MoveEnd wdCharacter, -1
    
    Dim res As String
     
    If regex.Replace(Replace(a.text, Chr(160), ""), "") = "" Then
    Debug.Print "empty"
    Selection.Delete
    End If
     
'    If a.text = vbCr Or a.text = vbLf Or a.text = vbCrLf Or a.text = vbNewLine Or a.text = vbTab Then
'   ' Debug.Print "newline"
'       bReplaced = True
'                Selection.Delete
'                GoTo restart
'
'    End If
'    If a.text = " " Then Selection.Delete
'
''
''             If regex.Test(a.text) Then
''                bReplaced = True
''                'a.text = regex.Replace(a.text, "")
''                Selection.Delete
''
''             End If
        End If
        DoEvents
    Loop
    
    If bReplaced Then MsgBox "Highlighted white-spaces have been removed."
    
    Set rngTemp = ActiveDocument.Range

    With rngTemp.Find
        .ClearFormatting
        .Highlight = True
        .Forward = True
        .Execute
    End With
    If rngTemp.Find.Found = True Then
        MsgBox ("There have been non-white-space highlights found, this usually means default text.")
    End If
    
    Application.ScreenUpdating = True

End Sub
  

Сначала я думал, что мне не следует заменять текст при активном выборе поиска, поэтому я попытался исправить это, создав версию 2 и вызвав selection .удалить, но почему-то это тоже не работает.

Обычный диалог поиска никогда не зацикливается, но символ пробела там не разрешен. Спасибо за вашу помощь.

Редактировать: я также попробовал это (удаляет только выделение; не удаляет пробелы, также при наличии новой строки / нового абзаца, который выделяется всякий раз, когда я нажимаю enter для вставки текста — это говорит о том, что разметка / выделение активны для символа новой строки / абзаца — я попробовал несколько вариантовнапример, ^w ^ p, но я не могу использовать его в сочетании с опцией «Использовать подстановочные знаки», когда я хочу использовать оператор OR)

 Sub Macro6()
'
' Macro6 Macro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Highlight = True
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Highlight = False
    With Selection.Find
        .Text = "^w"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub
  

Последняя версия:

 Sub RemoveHighlightedWhiteSpace()
   Application.ScreenUpdating = False
   With ActiveDocument.Content.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Highlight = True
      .Replacement.Highlight = False
      .text = "[ ,^9,^11,^12,^13," amp; Chr(160) amp; "," amp; Chr(164) amp; "]{2,}"
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .MatchWildcards = True
      .Execute Replace:=wdReplaceAll
   End With
   Application.ScreenUpdating = True
End Sub
  

Попробуйте приведенный ниже код. Единственный символ, который я не могу найти способ включить, — это vbLf .

Чтобы удалить выделение, вам нужно использовать Format = True , но это не приведет к удалению символов, поэтому их необходимо запускать отдельно.

 Sub DeleteHighlightedWhiteSpace()
   'finds at least any 2 of vbTab, vbVerticalTab, vbFormFeed, vbCr, non-breaking space
   Application.ScreenUpdating = False
   With ActiveDocument.Content.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Highlight = True
      .text = "[ ,^9,^11,^12,^13," amp; Chr(160) amp; "]{2,}"
      .Replacement.text = ""
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchWildcards = True
      .Execute Replace:=wdReplaceAll
   End With
   Application.ScreenUpdating = True
End Sub

Sub RemoveHighlighting()
   Application.ScreenUpdating = False
   With ActiveDocument.Content.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Highlight = True
      .Replacement.Highlight = False
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .Execute Replace:=wdReplaceAll
   End With
   Application.ScreenUpdating = True
End Sub
  

РЕДАКТИРОВАТЬ: то, чего вы пытаетесь достичь, все еще неясно. Из ваших комментариев кажется, что вы пытаетесь удалить все выделения из всего документа. Если это так, то есть простой способ сделать это:

 Sub RemoveAllHighlighting()
   Dim story As Range
   For Each story In ActiveDocument.StoryRanges
      story.HighlightColorIndex = wdNoHighlight
   Next story
End Sub