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
复制代码