[文本处理] 求批处理把1份复习题 自动生成试卷

sf2022

https://wwd.lanzouq.com/iCXQt049xfcj   所有文件在这里

目前有一份WORD复习题，想实现：
1、把生成一份测试试卷，把这份复习题中的每个红色字替换为4个“_”。
2、删除每题中的非红色字，仅保留红字，某题中如果有多组红字，则用一个全角空格隔开。前面的题号与第1步中对应不变。
3、将第2步中生成的内容追加到第1步的文件尾部，追加前插入“试题答案”字样，占一行。
PS：至此试卷部分题号是1-90题，答案部分题号也是1-90。
4、对项目编号进行文本化处理，即试卷和答案的题号都调整为普通文字。
Sub 项目编号文本化()
ActiveDocument.Content.ListFormat.ConvertNumbersToText
End Sub
  我用这个 但是之后会有一个“制表符”得替换删除，参考。
5、生成的文件名，和原文件名相同在后加“_试卷”。


就是把一份复习题，生成一份试卷，后面追加答案。

谢谢师兄，辛苦。

flashercs

Module1.bas
这是vba模块,导入就行

Attribute VB_Name = "Module1"
Sub NewExam2()
Attribute NewExam2.VB_Description = "生成试题和答案,在同一文档docx"
Attribute NewExam2.VB_ProcData.VB_Invoke_Func = "Normal.Module1.NewExam2"
' 宏
' 生成新试题和答案
'
On Error Resume Next
Const ExamName As String = "_试卷.docx"

Dim docSrc As Document, docExam As Document
Dim i As Long, oRange As range, oRange2 As range, itempara As Paragraph
Dim fso, examPath As String
Set fso = CreateObject("Scripting.FileSystemObject")

Set docSrc = ActiveDocument
If docSrc Is Nothing Then Exit Sub
examPath = fso.BuildPath(docSrc.Path, fso.GetBaseName(docSrc.Name) & ExamName)
If fso.FileExists(examPath) Then fso.DeleteFile examPath, True
If Err.Number <> 0 Then Exit Sub
docSrc.SaveAs2 examPath
Set docExam = ActiveDocument

Application.ScreenUpdating = False

docExam.ConvertNumbersToText

Set oRange = docExam.Content
oRange.SetRange oRange.Paragraphs(2).range.Start, oRange.End - 1
With oRange.Find
    .ClearFormatting
    .Text = "(^t{1,})"
    .MatchWildcards = True
    With .Replacement
        .ClearFormatting
        .Text = ""
    End With
    .Execute Replace:=wdReplaceAll
End With
oRange.Copy

Selection.EndKey wdStory
Selection.InsertNewPage
Selection.EndKey wdStory
Selection.InsertAfter "试题答案:"
Selection.InsertParagraphAfter
Selection.EndKey wdStory
Set oRange2 = Selection.range
oRange2.Paste

With oRange.Find
    .ClearFormatting
    .Font.ColorIndex = wdRed
    .Format = True
    .Text = "*"
    .MatchWildcards = True
    With .Replacement
        .ClearFormatting
        .Font.ColorIndex = wdAuto
        .Text = "____"
    End With
    .Execute Replace:=wdReplaceAll
End With
For Each itempara In oRange2.Paragraphs
    With itempara.range
        .MoveStartUntil "."
        .MoveStart wdCharacter, 1
        .MoveEnd wdCharacter, -1
        With .Find
            .ClearFormatting
            .Font.ColorIndex = wdAuto
            .Format = True
            .Text = "*"
            .MatchWildcards = True
            With .Replacement
                .ClearFormatting
                .Text = " "
            End With
            .Execute Replace:=wdReplaceAll
            .ClearFormatting
            .Format = False
            .Text = "( {1,})"
            .MatchWildcards = True
            With .Replacement
                .Text = " "
            End With
            .Execute Replace:=wdReplaceAll
        End With
        .Font.ColorIndex = wdRed
        .Text = Trim$(.Text)
    End With
Next
docExam.Save
'docExam.Close
Set fso = Nothing
Application.ScreenUpdating = True
MsgBox "生成试题和答案完成."

End Sub
复制代码

sf2022

回复 2# flashercs


    测试成功 感谢

sf2022

回复 2# flashercs

为什么生成的文件关闭后，就再也打不开了

能把代码改成VBS吗？或其他的，运行后 对当前目录下的所有WROD生效

谢谢

for_flr

请教大佬，如果用powershell，如何匹配到颜色字体

5i365

回复 2# flashercs


   感谢大侠分享, 要是能改成ps代码,就更好了, vba 看不懂