|
|
原帖由 tangqingfu 于 2009-5-28 18:15 发表 
To sylun兄:
我想将两种颜色一起提取出来,请教该如何修改代码?
我也知楼主的意思，只是这又要用不同的思路了。可试试如下代码，只是这种处理速度要慢些（如逐字判断更慢）。
Sub test7()
'没有选定内容则对全文档进行处理
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.Characters.First.Select
With Selection
Do
If .Font.Color = wdColorRed Or .Font.Color = wdColorWhite Then
.SelectCurrentColor
If .End > myRange.End Then Exit Do
num = Int(Val(.Paragraphs(1).Range.Text))
Do While num = 0
i = i + 1
num = Int(Val(.Previous(wdParagraph, i).Text))
If i > 10 Then Exit Do
Loop
Set tempRange = Doc.Bookmarks("\endofdoc").Range
tempRange.FormattedText = .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
End If
.Collapse wdCollapseEnd
.MoveRight wdCharacter, 1, wdExtend
Loop Until .End = myRange.End
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 |
评分
-
1
查看全部评分
-
|
楼主: tangqingfu
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2009-5-28 10:23
