如何解决删除突出显示的空白
我正在尝试通过宏从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.delete来修复它,但是以某种方式也行不通。
普通的搜索对话框永远不会循环,但是那里不允许有空格字符。 谢谢您的帮助。
编辑:我也尝试过此操作(仅删除突出显示;不删除空格,当我按下Enter键插入文本时也突出显示了换行符/新段落时,也是如此-这表明标记/突出显示在换行符/段落char上处于活动状态-我尝试了一些类似^ 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," & Chr(160) & "," & Chr(164) & "]{2,}"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub
解决方法
尝试下面的代码。我找不到包含的唯一字符是vbLf。
要删除突出显示,您需要使用begin routers
smarthost:
debug_print = "R: smarthost for $local_part@$domain"
driver = manualroute
headers_add = X-SES-CONFIGURATION-SET: CloudWatch
headers_add = X-SES-MESSAGE-TAGS: customer=senet,application=twentyfour
domains = ! +local_domains
transport = remote_smtp_smarthost
route_list = * email-smtp.eu-central-1.amazonaws.com:587 byname
host_find_failed = ignore
same_domain_copy_routing = yes
no_more
COND_LOCAL_SUBMITTER = "${if match_ip{$sender_host_address}{:@[]}{1}{0}}"
,但这不会删除字符,因此必须单独运行。
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," & Chr(160) & "]{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
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。