|
|
原帖由 tangqingfu 于 2009-5-24 20:30 发表 
总体效果很不错,运行速度很快!
能否对于选项不在同一段(行)的效果进行改进,如英文选择题中的第2、14小题；但如果在运行代码前将多段（行）选项中的前面选项后的段落标记替换为手动换行符，即只有一个段落，效果就很 ...
替换就不想了，因为要准确判断哪些是选择题并非易事，反而容易导致错漏。还是保持程序不对原文档作任何改动吧，我想这应是基本原则。
再对原程序稍作修改，看看所说的问题是否能解决。当然，程序的适应性还不可能是百分百的，毕竟它只是基于文档字符特征的判断。
Sub test6a()
'没有选定内容则对全文档进行处理
Dim oDoc As Document, Doc As Document
Dim myRange As Range, tempRange As Range
Dim num%, i%, info$, num2%
On Error Resume Next
Application.ScreenUpdating = False
Set oDoc = ActiveDocument
Set Doc = Documents.Add
oDoc.Activate
Set myRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
myRange.Select
With Selection.Find
.ClearFormatting
.Text = ""
.Font.Color = wdColorRed '答案内容以红色字体标注
.Format = True
.Replacement.ClearFormatting
Do While .Execute
If .Parent.End > myRange.End Then Exit Do
num = Int(Val(.Parent.Paragraphs(1).Range.Text))
Do While num = 0
i = i + 1
num = Int(Val(.Parent.Previous(wdParagraph, i).Text))
If i > 10 Then Exit Do '预防死循环
Loop
Set tempRange = Doc.Bookmarks("\endofdoc").Range
tempRange.FormattedText = .Parent.FormattedText
Do While tempRange.Characters.First Like "[ ]"
tempRange.Characters.First = ""
Loop
Do While tempRange.Characters.Last Like "[ ]"
tempRange.Characters.Last = ""
Loop
If Len(tempRange) > 0 Then
If tempRange Like "[!A-FＡ-Ｆ.．、]" = False Then
If tempRange.Characters.Last Like "[.．、]" Then tempRange.Characters.Last.Delete
End If
If num = num2 Then tempRange.InsertBefore " " Else tempRange.InsertBefore vbCrLf & IIf(num = num2, "", num & "．")
num2 = num
End If
i = 0
If .Parent.End = myRange.End Then Exit Do
Loop
End With
With Doc.Content
.Characters.First.Delete
With .Font
.Color = wdColorAutomatic
.Underline = wdUnderlineNone
.Bold = False
.Italic = False
End With
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = 0
.CharacterUnitLeftIndent = 0
.LeftIndent = 0
End With
With .Find
.MatchWildcards = True
.Execute "^13 ", replacewith:="^p", Replace:=wdReplaceAll
Do While .Execute("([． ])([A-FＡ-Ｆ]@)[^13 ]", replacewith:="\1\2 ", Replace:=wdReplaceOne)
.Parent.Collapse wdCollapseEnd
Loop
.Parent.WholeStory
Do While .Execute("([． ][A-FＡ-Ｆ]@) ([A-FＡ-Ｆ][^13 ])", replacewith:="\1\2", Replace:=wdReplaceOne)
.Parent.Collapse wdCollapseStart
Loop
.Parent.WholeStory
.Execute " ^13", replacewith:="^p", Replace:=wdReplaceAll
.Execute "([． ][A-FＡ-Ｆ]@) ([0-9]@．[!A-FＡ-Ｆ])", replacewith:="\1^p\2", Replace:=wdReplaceAll
.Execute "^13{2,}", replacewith:="^p", Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub |
|
楼主: tangqingfu
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2009-5-24 12:03
