frmbuild.frm

网上收集的一个考试管理系统。带论文的

VERSION 5.00
Begin VB.Form FrmBuild 
   BackColor       =   &H00404040&
   BorderStyle     =   0  'None
   Caption         =   "生成考题"
   ClientHeight    =   2595
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   6705
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2595
   ScaleWidth      =   6705
   StartUpPosition =   1  '所有者中心
   Begin VB.PictureBox PicPBar 
      BackColor       =   &H00404040&
      Height          =   285
      Left            =   450
      ScaleHeight     =   225
      ScaleWidth      =   5895
      TabIndex        =   3
      Top             =   1305
      Width           =   5955
   End
   Begin VB.CommandButton Command1 
      Caption         =   "开始做题"
      Height          =   420
      Left            =   2790
      TabIndex        =   2
      Top             =   1800
      Visible         =   0   'False
      Width           =   1185
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   495
      Top             =   720
   End
   Begin VB.Line Line3 
      BorderColor     =   &H0000FFFF&
      X1              =   0
      X2              =   6660
      Y1              =   2565
      Y2              =   2565
   End
   Begin VB.Line Line2 
      BorderColor     =   &H0000FFFF&
      X1              =   6660
      X2              =   6660
      Y1              =   180
      Y2              =   2610
   End
   Begin VB.Line Line1 
      BorderColor     =   &H0080FFFF&
      X1              =   0
      X2              =   0
      Y1              =   180
      Y2              =   2565
   End
   Begin VB.Label Label2 
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "生成考题"
      Height          =   240
      Left            =   2520
      TabIndex        =   1
      Top             =   90
      Width           =   1545
   End
   Begin VB.Shape Shape1 
      BackColor       =   &H0000FFFF&
      BackStyle       =   1  'Opaque
      BorderStyle     =   6  'Inside Solid
      Height          =   375
      Left            =   0
      Shape           =   2  'Oval
      Top             =   0
      Width           =   6675
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "正在随机生成考题请稍后"
      ForeColor       =   &H00C0FFFF&
      Height          =   180
      Left            =   2430
      TabIndex        =   0
      Top             =   945
      Width           =   1980
   End
End
Attribute VB_Name = "FrmBuild"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
    Dim RsSingle As ADODB.Recordset
    Dim RsOs As ADODB.Recordset
    Dim RsFill As ADODB.Recordset
    Dim RsMulti As ADODB.Recordset
    Dim Msg$
    Dim SQL$
Private PBar As New PicProgressBar
Private TWForm As New TransWindow

Private Sub Command1_Click()
'  Load FrmSelectTest
  'FrmSelectTest.Show
 ' Load FrmMultiSelectTest
  'FrmMultiSelectTest.Show
   Unload Me
  Load FrmFillTest
  FrmFillTest.Show
  FrmFillTest.TWForm.ShowForm
End Sub

Private Sub Form_Load()
'Me.Show
TWForm.SetForm Me
TWForm.ShowForm

If IsBak = False Then '没有备份文件
    'SelectSubject = 20
    'SelectSubjectValue = 5
    Call InitGlobe
    Timer1.Enabled = True

Else
    Label2.Caption = "还原题目"
    Label1.Caption = "正在还原题目"
        
    Call ResumeSubject

End If
End Sub

Sub RndSubject() '随机出题

Dim t As Long
Dim Chongfu As Boolean

Randomize
Dim FillNum As Integer

FillNum = 1
    SQL = "select * from FillSubject"
    Set RsFill = executeSQL(SQL, Msg)
          

   FillNum = 0
   ReDim FillSubject(0) As Long
      For i = 0 To Int(Val(FillSubjectCount)) - 1 '随机器产生填空题
      DoEvents
      Chongfu = True
          Do While Chongfu
          DoEvents
            t = Int(Rnd * RsFill.RecordCount)
             For j = 0 To UBound(FillSubject)
                If FillSubject(j) = t Then
                  Chongfu = True
                  Exit For
                End If
                 RsFill.MoveFirst
                 RsFill.Move t
             If Val(FillNum + RsFill.Fields(4)) > Val(FillSubjectCount) Then
                Chongfu = True
             End If
                Chongfu = False
             Next j
         Loop
             FillNum = FillNum + RsFill.Fields(4)
             ReDim Preserve FillSubject(UBound(FillSubject) + 1) As Long
             FillSubject(i) = t
             If Val(FillNum) = Val(FillSubjectCount) Then
                 Exit For
             End If
             PBar.picBarValue = PBar.picBarValue + 1
      Next i
      FillSubjectCount = UBound(FillSubject)
   
    Set RsFill = Nothing
'-----------------------------------------------------------------
    
    SQL = "select * from ChoiceExercise"
    Set RsSingle = executeSQL(SQL, Msg)

     For i = 0 To Int(Val(SingleChoiceSubjectCount)) - 1 '随机器产生单项选择题
     DoEvents
     Chongfu = True
         Do While Chongfu
         DoEvents
           t = Int(Rnd * RsSingle.RecordCount)
            For j = 0 To i
               If SingleChoiceSubject(j) = t Then
                 Chongfu = True
                 Exit For
               End If
               Chongfu = False
             Next j
         Loop
            SingleChoiceSubject(i) = t
             PBar.picBarValue = PBar.picBarValue + 1
            
     Next i
    Set RsSingle = Nothing
'-----------------------------------------------------------------
    
    
      SQL = "select * from MultiChoice"
      Set RsMulti = executeSQL(SQL, Msg)
      
     For i = 0 To Int(Val(MultiChoiceSubjectCount)) - 1 '随机器产生多项选择题
     DoEvents
     Chongfu = True
         Do While Chongfu
         DoEvents
           t = Int(Rnd * RsMulti.RecordCount)
            For j = 0 To i
               If MultiChoiceSubject(j) = t Then
                 Chongfu = True
                 Exit For
               End If
               Chongfu = False
             Next j
         Loop
            MultiChoiceSubject(i) = t
             PBar.picBarValue = PBar.picBarValue + 1
            
     Next i
    Set RsMulti = Nothing
'-----------------------------------------------------------------

      SQL = "select * from OperationExercise"
      Set RsOs = executeSQL(SQL, Msg)
      
    For i = 0 To Int(Val(OperationSubjectCount)) - 1 '随机器产生操作题
    DoEvents
       Chongfu = True
      Do While Chongfu
      DoEvents
        t = Int(Rnd * RsOs.RecordCount)
         For j = 0 To i
            If OperationSubject(j) = t Then
              Chongfu = True
              Exit For
            End If
            Chongfu = False
          Next j
      Loop
         OperationSubject(i) = t
         PBar.picBarValue = PBar.picBarValue + 1
    Next i

  Set RsOs = Nothing
'-----------------------------------------------------------------
  
    Call BakSubject
     PBar.picBarValue = PBar.picBarMax
     Label1.Caption = "已随机生成考题,请完成题目"
 
     Command1.Visible = True

End Sub
Function IsBak() As Boolean
    Dim CString As String * 255
     
    GetPrivateProfileString "IsBak", "IsNot", "", CString, Len(CString), App.Path & "\ExamBak.bak"
     
    If Val(CString) = 1 Then
        IsBak = True
    Else
        IsBak = False
    End If
End Function

Sub BakSubject() '备份题目
     WritePrivateProfileString "IsBak", "IsNot", "1", App.Path & "\ExamBak.bak"

     WritePrivateProfileString "FillSubjectCount", "Count", CStr(UBound(FillSubject)), App.Path & "\ExamBak.bak"
'     WritePrivateProfileString "FillSubjectCount", "Count", CStr(FillSubjectCount), App.Path & "\ExamBak.bak"
     
     WritePrivateProfileString "SingleChoiceCount", "Count", CStr(SingleChoiceSubjectCount), App.Path & "\ExamBak.bak"
     WritePrivateProfileString "MultiChoiceCount", "Count", CStr(MultiChoiceSubjectCount), App.Path & "\ExamBak.bak"
     WritePrivateProfileString "OperationCount", "Count", CStr(OperationSubjectCount), App.Path & "\ExamBak.bak"

     WritePrivateProfileString "FillSubjectValue", "Value", CStr(FillSubjectValue), App.Path & "\ExamBak.bak"
     WritePrivateProfileString "SingleChoiceValue", "Value", CStr(SingleChoiceSubjectValue), App.Path & "\ExamBak.bak"
     WritePrivateProfileString "MultiChoiceValue", "Value", CStr(MultiChoiceSubjectValue), App.Path & "\ExamBak.bak"
     WritePrivateProfileString "OperationValue", "Value", CStr(OperationSubjectValue), App.Path & "\ExamBak.bak"
    
     For i = 0 To UBound(FillSubject)
             WritePrivateProfileString "FillSubjectBak", "FillSubject" & CStr(i), CStr(FillSubject(i)), App.Path & "\ExamBak.bak"
     Next i
'---------------------------------------------------------------------------------

     WritePrivateProfileString "SingleChoiceCount", "Count", CStr(SingleChoiceSubjectCount), App.Path & "\ExamBak.bak"
    
     For i = 0 To UBound(SingleChoiceSubject)
             WritePrivateProfileString "SingleChoiceBak", "SingleChoice" & CStr(i), CStr(SingleChoiceSubject(i)), App.Path & "\ExamBak.bak"
     Next i
'---------------------------------------------------------------------------------

     WritePrivateProfileString "MultiChoiceCount", "Count", CStr(MultiChoiceSubjectCount), App.Path & "\ExamBak.bak"
    
     For i = 0 To UBound(MultiChoiceSubject)
             WritePrivateProfileString "MultiChoiceBak", "MultiChoice" & CStr(i), CStr(MultiChoiceSubject(i)), App.Path & "\ExamBak.bak"
     Next i
'---------------------------------------------------------------------------------
     WritePrivateProfileString "OperationCount", "Count", CStr(OperationSubjectCount), App.Path & "\ExamBak.bak"
        
     For i = 0 To UBound(OperationSubject)
             WritePrivateProfileString "OperationBak", "OperationSubject" & CStr(i), CStr(OperationSubject(i)), App.Path & "\ExamBak.bak"
     Next i
         
End Sub
Sub ResumeSubject() '恢复题目
'On Error Resume Next
    Dim CString As String * 255
    Dim Rs As ADODB.Recordset
    Dim SQL As String
    Dim Msg As String
    'Dim FillValCount As Integer
    'GetPrivateProfileString "FillSubjectValCount", "Count", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    'FillValCount = Val(CString)

    GetPrivateProfileString "FillSubjectCount", "Count", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    FillSubjectCount = Val(CString)

    GetPrivateProfileString "SingleChoiceCount", "Count", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    SingleChoiceSubjectCount = Val(CString)
    
    GetPrivateProfileString "MultiChoiceCount", "Count", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    MultiChoiceSubjectCount = Val(CString)
        
    GetPrivateProfileString "OperationCount", "Count", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    OperationSubjectCount = Val(CString)
    
    
    
    GetPrivateProfileString "FillSubjectValue", "Value", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    FillSubjectValue = Val(CString)

    GetPrivateProfileString "SingleChoiceValue", "Value", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    SingleChoiceSubjectValue = Val(CString)
    
    GetPrivateProfileString "MultiChoiceValue", "Value", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    MultiChoiceSubjectValue = Val(CString)
        
    GetPrivateProfileString "OperationValue", "Value", "", CString, Len(CString), App.Path & "\ExamBak.bak"
    OperationSubjectValue = Val(CString)
    
    
    ReDim FillSubject(Int(Val(FillSubjectCount))) As Long

    
    Call InitGlobe
    
    For i = 0 To UBound(FillSubject)
    DoEvents
        GetPrivateProfileString "FillSubjectBak", "FillSubject" & CStr(i), "", CString, Len(CString), App.Path & "\ExamBak.bak"
        FillSubject(i) = Val(CString)
        PBar.picBarValue = PBar.picBarValue + 1
    Next i
  
    For i = 0 To UBound(SingleChoiceSubject)
    DoEvents

        GetPrivateProfileString "SingleChoiceBak", "SingleChoice" & CStr(i), "", CString, Len(CString), App.Path & "\ExamBak.bak"
        SingleChoiceSubject(i) = Val(CString)
        PBar.picBarValue = PBar.picBarValue + 1
    Next i
    
    For i = 0 To UBound(MultiChoiceSubject)
    DoEvents
        GetPrivateProfileString "MultiChoiceBak", "MultiChoice" & CStr(i), "", CString, Len(CString), App.Path & "\ExamBak.bak"
        MultiChoiceSubject(i) = Val(CString)
        PBar.picBarValue = PBar.picBarValue + 1
    Next i
    
    
    For i = 0 To UBound(OperationSubject)
    DoEvents
        GetPrivateProfileString "OperationBak", "OperationSubject" & CStr(i), "", CString, Len(CString), App.Path & "\ExamBak.bak"
        OperationSubject(i) = Val(CString)
        PBar.picBarValue = PBar.picBarValue + 1
    Next i
     Load FrmFillTest
     Load FrmSelectTest
     Load FrmMultiSelectTest
     Load FrmOperation
    
     PBar.picBarValue = PBar.picBarMax
     Label1.Caption = "已还原考题,请继续完成题目"
     Command1.Caption = "继续做题"
     Command1.Visible = True

End Sub


Sub InitGlobe()

     'ReDim FillSubject(Int(Val(FillSubjectCount))) As Long
     ReDim SingleChoiceSubject(Int(Val(SingleChoiceSubjectCount))) As Long
     ReDim MultiChoiceSubject(Int(Val(MultiChoiceSubjectCount))) As Long
     ReDim OperationSubject(Int(Val(OperationSubjectCount))) As Long
 
     ReDim FillSelectQuestion(Int(Val(FillSubjectCount))) As String
     ReDim SingleSelectQuestion(Int(Val(SingleChoiceSubjectCount))) As String
     ReDim MultiSelectQuestion(Int(Val(MultiChoiceSubjectCount))) As String

     ReDim FillRightQuestion(Int(Val(FillSubjectCount))) As String
     ReDim SingleRightQuestion(Int(Val(SingleChoiceSubjectCount))) As String
     ReDim MultiRightQuestion(Int(Val(MultiChoiceSubjectCount))) As String
     
     ReDim FillSubjectRight(Int(Val(FillSubjectCount))) As Boolean
     ReDim SingleSelectRight(Int(Val(SingleChoiceSubjectCount))) As Boolean
     ReDim MultiSelectRight(Int(Val(MultiChoiceSubjectCount))) As Boolean
     
       PBar.SetPic Me.PicPBar
       PBar.picBarMin = 0
     
       PBar.picBarMax = Int(Val(FillSubjectCount)) + Int(Val(SingleChoiceSubjectCount)) + _
                Int(Val(MultiChoiceSubjectCount)) + Int(Val(OperationSubjectCount)) + 4
       PBar.picBarColor = &HFFC0C0
       PBar.picTextColor = &H4040&
       PBar.picBarValue = 0

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
TWForm.UnLoadForm
Set TWForm = Nothing
Set PBar = Nothing
End Sub

Private Sub Timer1_Timer()
  Call RndSubject
  Timer1.Enabled = False
End Sub