【VBA实战】使用Word制作简易的考试及阅卷系统

这个事源于公司想简化面试流程，希望能通过一些简单的笔试及自动阅卷来提高对候选人的初步筛选工作的效率和准确性。我当时的想法是这样的：

利用AI工具生成一个笔试题库，只要选择题和填空题
利用VBA工具，根据需求自动从题库里抽取响应的题目，生成试卷
答完试卷后，能自动进行阅卷打分

我花了差不多半天时间，做了一个小Demo来验证这个思路。不过这个事后来"夭折"了，因为稍微调研一下就知道，现在已经有很多成熟的可以帮你生成试卷并自动阅卷的考试系统了，而且收费也不贵，确实是用不上用Word来做这样一个简陋的系统。但是Demo做都做了，那就放出来，供有需要的朋友参考。

先看看运行效果：

简易考试系统

后续可以在考卷文件里加一个倒计时，并从题库里随机抽题，在做一些界面美化。这得看心情。

实现这个系统主要用到了Word的控件功能，在这里：

代码比较简单。这块稍微说一下阅卷的逻辑，我的试题其实是以表格的形式存储的，如下图：

我在生成试卷的时候，将对应试题答案的表格行列号存到了内容控件的Tag里，这样在阅卷的时候，只需要读取相应内容控件的Tag，解析出答案所在单元格的表格序号和行列号，然后读取题库中的答案和试卷上的答案进行对比就好了。

生成试卷的核心代码如下：

vbnet 复制代码

Private Sub GenTest_Click()
    Dim cc As ContentControl
    Dim post, level, time, cnum, jnum As String
    Dim rootPath As String
    
    rootPath = ActiveDocument.Path

    For Each cc In ActiveDocument.ContentControls
    
        If cc.Title = "Post" Then
            post = cc.Range.Text
        ElseIf cc.Title = "Level" Then
            level = cc.Range.Text
        ElseIf cc.Title = "Time" Then
            time = cc.Range.Text
        ElseIf cc.Title = "ChoiceNum" Then
            cnum = cc.Range.Text
        ElseIf cc.Title = "JudgeNum" Then
            jnum = cc.Range.Text
        End If
        
    Next cc
    
    Dim quesDoc, newDoc As Document
    
    Set quesDoc = Documents.Open(rootPath + "\Database\" + "C++\" + "0" + ".docx")
    
    Set newDoc = Documents.Add()
    
    newDoc.Activate
    Selection.TypeText "选择题（共" + cnum + "道）" + Chr(13)
    
    For i = 2 To CInt(cnum) + 1
    
        Selection.TypeText quesDoc.Tables(1).Cell(i, 1).Range.Text
        Selection.TypeText "答案："
        Set cc = newDoc.ContentControls.Add(wdContentControlDropdownList)
        cc.Tag = "1," + CStr(i)
        cc.DropdownListEntries.Add "A"
        cc.DropdownListEntries.Add "B"
        cc.DropdownListEntries.Add "C"
        cc.DropdownListEntries.Add "D"
        Selection.MoveRight wdCharacter, 2
        Selection.TypeText Chr(13) + Chr(13)
        
    Next i
    
    Selection.TypeText "判断题（共" + cnum + "道）" + Chr(13)
    For i = 2 To CInt(jnum) + 1
    
        Selection.TypeText quesDoc.Tables(2).Cell(i, 1).Range.Text
        Selection.TypeText "答案："
        Set cc = newDoc.ContentControls.Add(wdContentControlDropdownList)
        cc.Tag = "2," + CStr(i)
        cc.DropdownListEntries.Add "对"
        cc.DropdownListEntries.Add "错"
        Selection.MoveRight wdCharacter, 2
        Selection.TypeText Chr(13) + Chr(13)
        
    Next i
    
    quesDoc.Close
    
    newDoc.Protect wdAllowOnlyFormFields, False, "tianta"
    newDoc.Save
    newDoc.Close
    
End Sub

阅卷的核心代码如下：

vbnet 复制代码

Sub CheckPaper()

    Dim rootPath As String
    rootPath = ActiveDocument.Path

    Dim dlgOpen As FileDialog
    Set dlgOpen = Application.FileDialog( _
    FileDialogType:=msoFileDialogOpen)
    With dlgOpen
    .Show
    End With
    
    Dim paperDoc, quesDoc As Document
    Set paperDoc = Documents.Open(dlgOpen.SelectedItems(1))
    'paperDoc.Unprotect "tianta"
    
    Set quesDoc = Documents.Open(rootPath + "\Database\" + "C++\" + "0" + ".docx")
    
    paperDoc.Activate
    
    Dim cc As ContentControl
    Dim all, right, wrong As Integer
    For Each cc In paperDoc.ContentControls
        all = all + 1
        res = cc.Range.Text
        posArr = Split(cc.Tag, ",")
        i = CInt(posArr(0))
        j = CInt(posArr(1))
        ans = Left(quesDoc.Tables(i).Cell(j, 2).Range.Text, 1)
        
        If res = ans Then
            right = right + 1
        Else
            wrong = wrong + 1
        End If
        
    Next cc
    
    MsgBox "共" + CStr(all) + "题" + Chr(13) + "做对" + CStr(right) + "题" + Chr(13) + "做错" + CStr(wrong) + "题" + Chr(13) + "得" + CStr(right / all * 100) + "分"
    
    paperDoc.Close
    quesDoc.Close
    
End Sub

完整工程代码可以从这里下载：https://download.csdn.net/download/lc19890709/90025102