【VBA研究】VBA做了个简单的试题生成工具

作者：iamlasong

单位对新上岗的员工进行培训，培训结束后，需要进行考试，需要一个简单的考试系统，让新员工既可以自己练习，也可以进行测试，为此，我们做了一个题库，员工可以自己生成一套考题，测试自己的掌握程度，也可以集中起来进行考试，测试培训效果。

系统数据库很简单，主要有两个表，一个是题库，一个是成绩。

create table EMSAPP_TEST_QUESTION
(
  type                  CHAR(1),
  id                    NUMBER(4),
  question              VARCHAR2(400),
  choice_a              VARCHAR2(200),
  choice_b              VARCHAR2(200),
  choice_c              VARCHAR2(200),
  choice_d              VARCHAR2(200),
  answer                VARCHAR2(8),
  remark                VARCHAR2(20)
);

create table EMSAPP_TEST_RESULT
(
  city                  VARCHAR2(10),
  bureau_code           VARCHAR2(40),
  bureau_name           VARCHAR2(40),
  staff_code            VARCHAR2(10),
  staff_name            VARCHAR2(10),
  testdate              DATE,
  score                 number(3)
);

1、界面

分两块，考试部分和试题录入修改部分，下图是考试部分，上半部分是历史成绩查询工具，下半部分是试题生成和答案提交，生成的试题分别放在不同的工作表中，做完题目后提交答案，系统给出分数，同时，给出对错。

2、生成试题

生成的试题和标准答案都放在相应的工作表中，以便核对答案。

' 生成考试题Public Sub get_question()    '    On Error GoTo ErrMsg1:        Dim i, j, k, tp, lineno As Integer    Dim OraOpen As Boolean    Dim RndNumber, TempRnd(20), Recno, Maxno As Integer    Dim stName As String        Worksheets("系统参数").Select    For i = 7 To 11        If Len(Cells(i, 2)) < 3 Then            msg = MsgBox("请填写完整揽投员信息后再生成试题!", vbOKOnly, "iamlaosong")            Exit Sub         End If    Next i    ActiveSheet.unprotect password = "iamlaosong"    Cells(i, 2) = ""       '清除以前的分数    ActiveSheet.protect password = "iamlaosong"    Set cnn = CreateObject("ADODB.Connection")    Set rst = CreateObject("ADODB.Recordset")    sqls = "connect database"        cnn.Open "Provider=msdaora;Data Source=dl580;User Id=emssxjk;Password=emssxjk;"    OraOpen = True '成功执行后，数据库即被打开        'If OraOpen Then lineno = [D65536].End(xlUp).Row Else lineno = 0       '行数            Randomize (Timer)           '初始化随机数生成器    '生成试题    For tp = 0 To 2        If tp = 1 Then            Maxno = 20            stName = "单选"        ElseIf tp = 2 Then            Maxno = 20            stName = "多选"        Else            Maxno = 10            stName = "判断"        End If        sqls = "select count(*) from EMSAPP_TEST_QUESTION where type ='" & tp & "'"        Set rst = cnn.Execute(sqls)        Recno = rst(0)                k = 1        Worksheets(stName).unprotect password = "iamlaosong"   '工作表解锁以便写入题目和答案        Do While k <= Maxno            RndNumber = Int(Recno * Rnd) + 1            TempRnd(k) = RndNumber            For i = 1 To k - 1                If TempRnd(i) = RndNumber Then Exit For            Next i            If i = k Then    ' no repeat                sqls = "select question,choice_a,choice_b, choice_c,choice_d,answer from emsapp_test_question "                sqls = sqls & "where type ='" & tp & "' and ID =" & RndNumber                Set rst = cnn.Execute(sqls)                If Not (rst.EOF) Then   'exists                    k = k + 1                    For j = 1 To 6                        Worksheets(stName).Cells(k, j) = rst(j - 1)                    Next j                    Worksheets(stName).Cells(k, j) = ""        '清理上一次答案                    Worksheets(stName).Cells(k, j + 1) = ""    '清理上一次评分                End If            End If        Loop        Worksheets(stName).protect password = "iamlaosong", AllowFormattingRows:=True    '工作表加锁，防止修改    Next tp        rst.Close    Set rst = Nothing    cnn.Close    Set cnn = Nothing        msg = MsgBox("试题生成完毕，请答题!", vbOKOnly, "iamlaosong")        Exit SubErrMsg1:    OraOpen = False    MsgBox sqls, vbCritical, "操作失败 ，请检查！"End Sub

3、提交答案

根据标准答案给出每题得分并算出总分，保存到数据库中。

' 评分并提交结果Public Sub get_answer()    '    On Error GoTo ErrMsg1:        Dim i, j, k, tp, score As Integer    Dim OraOpen As Boolean    Dim stName, staff_inf As String        '根据成绩栏判断是否重复提交，生成新题时该单元格清空，提交答案后里面保存总分。    If Cells(12, 2) <> "" Then        msg = MsgBox("考试成绩已提交，请重新生成考题！", vbOKOnly, "iamlaosong")        Exit Sub    End If        Set cnn = CreateObject("ADODB.Connection")    Set rst = CreateObject("ADODB.Recordset")    sqls = "connect database"        cnn.Open "Provider=msdaora;Data Source=dl580;User Id=emssxjk;Password=emssxjk;"    OraOpen = True '成功执行后，数据库即被打开        'If OraOpen Then lineno = [D65536].End(xlUp).Row Else lineno = 0       '行数            sqls = "get score"    score = 0    '评分    For tp = 0 To 2        If tp = 1 Then            Maxno = 20            stName = "单选"        ElseIf tp = 2 Then            Maxno = 20            stName = "多选"        Else            Maxno = 10            stName = "判断"        End If                For k = 2 To Maxno + 1            If UCase(Worksheets(stName).Cells(k, 6)) = UCase(Worksheets(stName).Cells(k, 7)) Then                score = score + 2                Worksheets(stName).Cells(k, 8) = 2            Else                Worksheets(stName).Cells(k, 8) = 0            End If        Next k            Next tp        ActiveSheet.unprotect password = "iamlaosong"    Cells(12, 2) = score       '分数保存在12行    ActiveSheet.protect password = "iamlaosong"    For i = 7 To 12        staff_inf = staff_inf & " '" & Worksheets("系统参数").Cells(i, 2) & "',"    Next i        staff_inf = staff_inf & "to_date('" & Date & "','yyyy-mm-dd') "    sqls = "insert into emsapp_test_result (city,bureau_code,bureau_name,staff_code,staff_name,score,testdate) values ("    sqls = sqls & staff_inf & ")"    'MsgBox sqls    Set rst = cnn.Execute(sqls)        cnn.Close    Set cnn = Nothing    msg = MsgBox("考试成绩为：" & score, vbOKOnly, "iamlaosong")        Exit SubErrMsg1:    OraOpen = False    MsgBox sqls, vbCritical, "操作失败 ，请检查！"End Sub

4、成绩查询

关于这一块，只是我以前做的工具的一个应用，只要换个SQL语句就行了，详情看我的早期文章：

http://blog.csdn.net/iamlaosong/article/details/8465177

5、管理部分

主要功能是题目的录入和修改，没有这个管理部分并不影响试题部分的使用，只要人工将题目导入即可。这部分内容较多，涉及用户登录、密码修改、试题录入、修改等等，就不一一叙说了。

下面是登录界面和程序：

Private Sub CommandButton1_Click()    '用户名和密码校验    On Error GoTo ErrMsg1:        Dim i, j, lineno As Integer    Dim OraOpen As Boolean        Set cnn = CreateObject("ADODB.Connection")    Set rst = CreateObject("ADODB.Recordset")    sqls = "connect database"        cnn.Open "Provider=msdaora;Data Source=dl580;User Id=emssxjk;Password=emssxjk;"    OraOpen = True '成功执行后，数据库即被打开        'If OraOpen Then lineno = [D65536].End(xlUp).Row Else lineno = 0       '行数        id = TextBox1.Value    pwd = TextBox2.Value    sqls = "select city from emsapp_tb_user where flag='1' and id ='" & id & "' and pwd ='" & pwd & "'"    Set rst = cnn.Execute(sqls)    'MsgBox sqls    If Not (rst.EOF) Then        thiscity = rst(0)        msg = MsgBox("登录成功，用户名：" & id & "(" & thiscity & ")", vbOKOnly, "iamlaosong")        UserForm1.Hide    Else        msg = MsgBox("登录失败，请核对用户名和密码！", vbOKOnly, "iamlaosong")    End If        rst.Close    Set rst = Nothing    cnn.Close    Set cnn = Nothing        Exit SubErrMsg1:    OraOpen = False    MsgBox sqls, vbCritical, "操作失败 ，请检查！"End Sub

Private Sub CommandButton2_Click()    Application.QuitEnd SubPrivate Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)    CommandButton1_ClickEnd SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)    Application.QuitEnd Sub