如何通过VBA提取指定颜色的文字及其题号?

tangqingfu · 发表于 2009-5-22 16:19

谢谢sylun兄，测试通过，收藏学习！

tangqingfu · 发表于 2009-5-22 22:20

请教sylun兄:
如果有再添加像"简答题"这样的题目(加上原来的填空题和选择题),又该如何处理?试了10楼的代码,处理效果不是很理想.

chuhaiou · 发表于 2009-5-22 23:28

生成的答案最好是:所有选择题作一个段落,填空题一题一个段落,答案中若有嵌入式图片也能兼顾!

sylun · 发表于 2009-5-23 12:21

原帖由 tangqingfu 于 2009-5-22 22:20 发表
请教sylun兄:
如果有再添加像"简答题"这样的题目(加上原来的填空题和选择题),又该如何处理?试了10楼的代码,处理效果不是很理想.

那就用另一种方法吧：
Sub test3()
Dim myRange As Range
Dim num%, i%, info$, num2%, myend&
On Error Resume Next
Application.ScreenUpdating = False
Set myRange = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
myRange.Select
With Selection.Find
.ClearFormatting
.Font.Color = wdColorRed
.Format = True
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
      If .Parent.Paragraphs(1).Range.End = myend Then
         info = info & "　　" & Trim(.Parent)
      Else
         info = info & vbCrLf & IIf(num = num2, "", num & "．") & Trim(.Parent)
      End If
      myend = .Parent.Paragraphs(1).Range.End
      num2 = num
      i = 0
      If .Parent.End = myRange.End Then Exit Do
Loop
End With
Documents.Add.Content = info
With ActiveDocument.Content
.Characters.First.Delete
.Find.Execute "^p　　", replacewith:="^p", Replace:=wdReplaceAll
.Find.Execute "^p^p", replacewith:="^p", Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub

chuhaiou · 发表于 2009-5-23 12:56

生成的答案最好是:所有选择题作一个段落(选择题一题一个段落打印时浪费纸张,而重新调整段落又费时),填空题一题一个段落,答案中若有嵌入式图片(这种情况在有些学科上经常出现)也能兼顾!题号用自动域"AUTONUM"编号的方便,也考虑一下为好.

[ 本帖最后由 chuhaiou 于 2009-5-23 12:59 编辑 ]

sylun · 发表于 2009-5-23 13:01

原帖由 chuhaiou 于 2009-5-22 23:28 发表
生成的答案最好是:所有选择题作一个段落,填空题一题一个段落,答案中若有嵌入式图片也能兼顾!

第一个问题主要是如何判断当前匹配内容是不是属于选择题，不同的试卷会有不同的排版方式，估计不好用统一的标准判断，故从略，在生成的文档中用查找替换手工处理应很方便。
至于第二个问题，因前面的程序只获取相关文本，而不是带格式内容。要获取带格式内容，可试试如下代码，但要注意此时图片所在字符位置的字体颜色设置也应为红色：
Sub test4()
Dim oDoc As Document, Doc As Document
Dim myRange As Range
Dim num%, i%, info$, num2%, myend&
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
.Font.Color = wdColorRed
.Format = True
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
      If .Parent.Paragraphs(1).Range.End = myend Then
         Doc.Content.InsertAfter "　　"
      Else
         Doc.Content.InsertAfter vbCrLf & IIf(num = num2, "", num & "．")
      End If
      Doc.Bookmarks("\endofdoc").Range.FormattedText = .Parent.FormattedText
      myend = .Parent.Paragraphs(1).Range.End
      num2 = num
      i = 0
      If .Parent.End = myRange.End Then Exit Do
Loop
End With
With Doc.Content
.Characters.First.Delete
With .Find
      .Execute "^p　　", replacewith:="^p", Replace:=wdReplaceAll
      .Execute "^p^p", replacewith:="^p", Replace:=wdReplaceAll
      .Font.Color = wdColorRed
      .Replacement.Font.Color = wdColorAutomatic
      .Execute "", Format:=True, replacewith:="^&", Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub

sylun · 发表于 2009-5-23 13:15

原帖由 chuhaiou 于 2009-5-23 12:56 发表
...题号用自动域"AUTONUM"编号的方便,也考虑一下为好.

请看看7楼的回复。其实可以运行代码前先取消文档中域的链接（先Ctrl+A再Ctrl+shift+F9），代码运行后再撤销操作，这样处理更合适。

chuhaiou · 发表于 2009-5-23 18:31

Sub test4()
Dim oDoc As Document, Doc As Document
Dim myRange As Range
Dim num%, i%, info$, num2%, myend&
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
.Font.Color = wdColorRed
.Format = True
ActiveDocument.Fields.Unlink
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
      If .Parent.Paragraphs(1).Range.End = myend Then
         Doc.Content.InsertAfter "　　"
      Else
         Doc.Content.InsertAfter vbCrLf & IIf(num = num2, "", num & "．")
      End If
      Doc.Bookmarks("\endofdoc").Range.FormattedText = .Parent.FormattedText
      myend = .Parent.Paragraphs(1).Range.End
      num2 = num
      i = 0
      If .Parent.End = myRange.End Then Exit Do
Loop
ActiveDocument.Undo
End With
With Doc.Content
.Characters.First.Delete
With .Find
      .Execute "^p　　", replacewith:="^p", Replace:=wdReplaceAll
      .Execute "^p^p", replacewith:="^p", Replace:=wdReplaceAll
      .Font.Color = wdColorRed
      .Replacement.Font.Color = wdColorAutomatic
      .Execute "", Format:=True, replacewith:="^&", Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub

chuhaiou · 发表于 2009-5-23 18:42

现在只是将选择题合并成一个段落了!
1．正确的是(  )
A．好了    B．在此    C．要求    D．模范
2．正确的是( )
A．模式    B．械    C．棋艺    D．松松散散
3．正确的是( )
A．相去甚远    B．本地区    C．雾茫茫    D．上级
4．正确的是( )
A．西班牙    B．豆芽菜    C．形式    D．要不是
题目中的正确答案选项已经标记成了红色

想将答案成这样:
1.A 2.B 3.D 4.BC

tangqingfu · 发表于 2009-5-23 18:51

谢谢sylun兄,测试成功,也感谢chuhaiou兄将帖子进一步深入讨论,收藏学习!

		自动登录	找回密码
密码			免费注册

[求助] 如何通过VBA提取指定颜色的文字及其题号?

题号用自动域"AUTONUM"编号也行了