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

tangqingfu

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

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

c81

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

替换为半角空格

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

chuhaiou

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

sylun

可试试如下代码（假设每小题一个段落）：
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

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

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

tangqingfu

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

sylun

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

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

sylun

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

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

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

tangqingfu

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

sylun

可试试：
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