【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 Sub
ErrMsg1:
    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 Sub
ErrMsg1:
    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 Sub
ErrMsg1:
    OraOpen = False
    MsgBox sqls, vbCritical, "操作失败 ,请检查!"

End Sub

Private Sub CommandButton2_Click()
    Application.Quit
End Sub


Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    CommandButton1_Click
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Application.Quit
End Sub





  • 3
    点赞
  • 26
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值