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

tangqingfu · 发表于 2009-5-21 19:35

请教如何通过VBA提取白色字体文字(下划线上的内容)及其题号,并生成一个新的文档，文档名称为“原文档名称+参考答案”?各小题中非连续区域用两个全角空格进行分隔。

[ 本帖最后由 tangqingfu 于 2009-5-29 09:18 编辑 ]

c81 · 发表于 2009-5-21 20:29

查找任意字符
选项：通配符
格式：字体颜色：自动设置

替换为半角空格

完成后将所得字体颜色变回，将多余的半角空格替换一下，给每个段加个自动编号，再稍加处理即可

chuhaiou · 发表于 2009-5-21 22:18

<<化学金排>>中提取答案就能实现你的要求,问王长春吧!

sylun · 发表于 2009-5-21 22:59

可试试如下代码（假设每小题一个段落）：
Sub test()
Dim aPar As Paragraph, TF As Boolean, temp As String, info As String
Application.ScreenUpdating = False
For Each aPar In ActiveDocument.Paragraphs
With aPar.Range.Find
      .ClearFormatting
      .Font.Color = wdColorWhite
      .Format = True
      Do While .Execute
         TF = True
         temp = temp & .Parent & "　　"
         .Parent.SetRange .Parent.End, .Parent.Paragraphs(1).Range.End - 1
      Loop
      If TF = True Then
         info = info & Int(Val(aPar.Range.Text)) & "．" & Trim(temp) & vbCrLf
         TF = False
         temp = ""
      End If
End With
Next
Documents.Add.Content = info
Application.ScreenUpdating = True
End Sub

chuhaiou · 发表于 2009-5-22 07:44

你做的非常好,运行速度比<<化学金排>>快多了!有个问题想请教:如果题号是自动域"AUTONUM"进行编号的,又如何实现提取题号和答案呢?有附件.

[ 本帖最后由 chuhaiou 于 2009-5-22 08:03 编辑 ]

tangqingfu · 发表于 2009-5-22 08:06

谢谢sylun兄的代码，效果很不错，同样适用于自动编号，如果有些小题的段落是多于一段的，代码该如何写呢？

sylun · 发表于 2009-5-22 08:51

原帖由 chuhaiou 于 2009-5-22 07:44 发表
有个问题想请教:如果题号是自动域"AUTONUM"进行编号的,又如何实现提取题号和答案呢?有附件.

试在For Each...In语句前加一行：ActiveDocument.Fields.Unlink，并在Next句后加一行：ActiveDocument.Undo

sylun · 发表于 2009-5-22 09:09

原帖由 tangqingfu 于 2009-5-22 08:06 发表
谢谢sylun兄的代码，效果很不错，同样适用于自动编号，如果有些小题的段落是多于一段的，代码该如何写呢？

试在Documents.Add...句后加一行：ActiveDocument.Content.Find.Execute "^p0．", replacewith:="　　", Replace:=wdReplaceAll
只是假如这样的段落以数字开头，则作为单独的小题对待。估计这样的可能性很小，故不想改用另一种方式处理。

[ 本帖最后由 sylun 于 2009-5-22 09:12 编辑 ]

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

请教sylun兄：
如何是选择题，代码该怎么写？（我试图将4楼代码中的White改为Red，但生成的题号均为0），能否将选择题和填空题的情况整合到代码中?（如何通过VBA提取红色字体文字及其题号? ）

sylun · 发表于 2009-5-22 11:07

可试试：
Sub test2()
Dim aPar As Paragraph, TF As Boolean
Dim temp As String, num As Integer, i As Integer, info As String
On Error Resume Next
Application.ScreenUpdating = False
'ActiveDocument.Fields.Unlink
For Each aPar In ActiveDocument.Paragraphs
With aPar.Range.Find
      .ClearFormatting
      .Font.Color = wdColorRed
      .Format = True
      Do While .Execute
         TF = True
         temp = temp & .Parent & "　　"
         .Parent.SetRange .Parent.End, .Parent.Paragraphs(1).Range.End - 1
      Loop
      If TF = True Then
         num = Int(Val(aPar.Range.Text))
         Do While num = 0
            i = i + 1
            num = Int(Val(aPar.Previous(i).Range.Text))
            If i > 10 Then Exit Do  '预防死循环
         Loop
         info = info & num & "．" & Trim(temp) & vbCrLf
         TF = False
         temp = ""
         i = 0
      End If
End With
Next
'ActiveDocument.Undo
Documents.Add.Content = info
ActiveDocument.Content.Find.Execute "^p0．", replacewith:="　　", Replace:=wdReplaceAll
Application.ScreenUpdating = True
End Sub

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

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

回复 1楼 tangqingfu 的帖子

回复 4楼 sylun 的帖子