【VBA研究】VBA做了個簡單的試題產生工具

標籤：excel   vba   sql   

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、管理部分

主要功能是題目的錄入和修改，沒有這個管理部分並不影響試題部分的使用，只要人工將題目匯入即可。這部分內容較多，涉及使用者登入、密碼修改、試題錄入、修改等等，就不一一敘說了。

下面是登入介面和程式：

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