继续修改,希望避免更正无效并复原时可能出现多添加空格的情形,并加了纠错语句,但好像不用纠错语句对18楼的附件也可通过。请再作测试 Sub correct_err() ' Dim myRange As Range, myErrors As Variant, myerr As Range Dim n As Integer, c As Integer, errtxt As String, b As Boolean On Error Resume Next Set myErrors = ThisDocument.Range.SpellingErrors n = myErrors.Count For Each myerr In myErrors Set myRange = myerr errtxt = myerr.Text b = False With myRange '先尝试与前一word合并 While Not (.Words(1).Previous Is Nothing) .SetRange Start:=.Words(1).Previous(wdWord).Start, End:=.End If InStr(.Text, "’") > 0 Then '此处引号内的符号为中文标点’ .SetRange Start:=.Words(1).Previous(wdWord,2).Start, End:=.End End If If InStr(.Text, Chr(32)) > 0 Then b = True .Text = Replace(.Text, Chr(32), "") End If .HighlightColorIndex = wdYellow c = c + 1 '如果仍有错,则复原并与后一word合并 If .SpellingErrors.Count > 0 Then If b = True Then .Text = Replace(.Text, errtxt, Chr(32) & errtxt, 1) b = False End If .HighlightColorIndex = wdNoHighlight c = c - 1 If .Words.Count > 1 Then While Not (.Words(2).Next Is Nothing) .SetRange Start:=.Words(2).Start, End:=.Words(2).Next.End If InStr(.Text, Chr(32)) > 0 Then b = True .Text = Replace(.Text, Chr(32), "") End If .Select .HighlightColorIndex = wdYellow c = c + 1 '如果错误仍未消除,则复原 If .SpellingErrors.Count > 0 Then If b = True Then .Text = Replace(.Text, errtxt, errtxt & Chr(32), 1) b = False End If .HighlightColorIndex = wdNoHighlight c = c - 1 End If GoTo NF Wend Else End If End If GoTo NF Wend End With NF: Next myerr MsgBox "共发现" & n & "个错误,并尝试更正了" & c & "个(突出显示部分)。", vbInformation End Sub
[此贴子已经被作者于2007-3-27 17:38:52编辑过] |