作者：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
根据标准答案给出每题得分并算出总分，保存到数据库中。
' 评分并提交结果
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
主要功能是题目的录入和修改，没有这个管理部分并不影响试题部分的使用，只要人工将题目导入即可。这部分内容较多，涉及用户登录、密码修改、试题录入、修改等等，就不一一叙说了。
下面是登录界面和程序：
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
【VBA研究】VBA做了个简单的试题生成工具,布布扣,bubuko.com
原文地址：http://blog.csdn.net/iamlaosong/article/details/38510329
