frmmain.frm

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

Public Sub Init()  '管理系统运行初始化
Dim CString As String * 255
Dim hMenu As Long, hSubMenu As Long, menuID As Long

INIFilePath = App.Path & "\"
    HostState = False
HostFileState = False

    GetPrivateProfileString "FillSubject", "Count", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    FillSubject = Val(CString)
    GetPrivateProfileString "FillSubject", "Value", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    FillSubjectValue = Val(CString)

    GetPrivateProfileString "Select", "Count", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    SelectSubject = Val(CString)
    GetPrivateProfileString "Select", "Value", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    SelectSubjectValue = Val(CString)
 
    GetPrivateProfileString "MultiSelect", "Count", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    MultiSelectSubject = Val(CString)
    GetPrivateProfileString "MultiSelect", "Value", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    MultiSelectSubjectValue = Val(CString)
       
    
    GetPrivateProfileString "Operation", "Count", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    OperationSubject = Val(CString)
    GetPrivateProfileString "Operation", "Value", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    OperationSubjectValue = Val(CString)
    
    GetPrivateProfileString "Time", "Value", "", CString, Len(CString), INIFilePath & "ExamSetup.ini"
    ExamTime = Val(CString)
    FrmMain.Text3.Text = FrmMain.Winsock1(0).LocalIP
  
Load Frmlogin
Me.Show
Frmlogin.Show 1
If UserName = Empty Then
    End
End If
End Sub




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

Private Sub Timer1_Timer()
'If WskFileComm(0).State <> 7 Then
'   HostFileState = False
'End If
End Sub





Private Sub Form_Resize()
On Error Resume Next
Frame1.Width = Me.Width - 100
LVStudentState.Width = Me.Width - 220
Frame2.Width = Frame1.Width
Frame2.Top = Me.Height - Frame2.Height - 750

Frame1.Height = Frame2.Top - Frame1.Top - 50

LVStudentState.Height = Frame2.Top - Frame1.Top - 320

End Sub

Private Sub LVStudentState_Click()
On Error Resume Next
With LVStudentState
    Text2.Text = .SelectedItem.SubItems(3)
    Label5.Caption = .SelectedItem.SubItems(1)

End With
End Sub

Private Sub MenuAboutAuthor_Click()

End Sub

Private Sub MenuAboutProgram_Click()
  

End Sub

Private Sub MenuAddFillSubject_Click()
Load FrmAddFillSubject
FrmAddFillSubject.Show
End Sub

Private Sub MenuAddMultiSubject_Click()
Load FrmAddMultiChoice
FrmAddMultiChoice.Show

End Sub

Private Sub MenuAddOSubject_Click()
Load FrmAddOperation
FrmAddOperation.Show
End Sub

Private Sub MenuAddStudent_Click()
Load FrmAddStudent
FrmAddStudent.Show
End Sub

Private Sub MenuAddSubject_Click()
Load FrmAddSubject
FrmAddSubject.Show
End Sub

Private Sub MenuAddUser_Click()
If UserType <> "admin" Then
   MsgBox "你无权做此操作", vbInformation, "权限禁用"
   
   Exit Sub
End If
Load FrmAddUser
FrmAddUser.Show
End Sub

Private Sub MenuEditFillSubject_Click()
Load FrmEditFillSubject
FrmEditFillSubject.Show
End Sub

Private Sub MenuEditMultiSubject_Click()
Load FrmEditMultiChoice
FrmEditMultiChoice.Show

End Sub

Private Sub MenuEditOSubject_Click()
Load FrmEditOperation
FrmEditOperation.Show
End Sub

Private Sub MenuEditPW_Click()
Load FrmEditPW
FrmEditPW.Show
End Sub

Private Sub MenuEditStudent_Click()
Load FrmEditStudent
FrmEditStudent.Show
End Sub

Private Sub MenuEditSubject_Click()
Load FrmEditSubject
FrmEditSubject.Show
End Sub



Private Sub MenuExit_Click()
If UserType <> "admin" Then
   MsgBox "你无权做此操作", vbInformation, "权限禁用"
   
   Exit Sub
End If
If MsgBox("确定要退出系统？", vbQuestion + vbYesNo, App.Title) = vbYes Then
 End
End If
End Sub

Private Sub MenuSetupExamInfo_Click()
If UserType <> "admin" Then
   MsgBox "你无权做此操作", vbInformation, "权限禁用"
   
   Exit Sub
End If

Load FrmExamSetup
FrmExamSetup.Show 1

End Sub

Private Sub MenuStartExam_Click()
    Dim Rs As ADODB.Recordset
      Dim Msg$
    Dim SQL$
    DBName = ChoiceExerciseDB
SQL = "select * from ChoiceExercise"
Set Rs = executeSQL(SQL, Msg, DBName)

If Rs.RecordCount <= Val(SelectSubject) Then
    MsgBox "选择题题库题目太少", vbInformation, "警告"
    Set Rs = Nothing
    Exit Sub
End If
    DBName = ChoiceExerciseDB
SQL = "select * from OperationExercise"
Set Rs = executeSQL(SQL, Msg, DBName)

If Rs.RecordCount <= Val(OperationSubject) Then
    MsgBox "操作题题库题目太少", vbInformation, "警告"
    Set Rs = Nothing
    Exit Sub
End If

If UserType <> "admin" Then
   MsgBox "你无权做此操作", vbInformation, "权限禁用"
   
  Exit Sub
End If

If Text3.Text = Empty Then
   MsgBox "请输入服务器地址", vbInformation, "提示"
   Text3.SetFocus
   Exit Sub
End If
If Text3.Enabled = True Then
Winsock1(0).Bind 10088, FrmMain.Text3.Text
Winsock1(0).Listen
WskFileBind.Bind 10087, Text3.Text
WskFileBind.Listen
Text3.Enabled = False
Else
  MsgBox "已经考试中了... ...", vbInformation, "提示"
End If
End Sub

Private Sub MenuUserLogin_Click()
Load Frmlogin
Frmlogin.Show 1
UserName = Empty
UserType = Empty
If UserName = Empty Then
    End
End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Caption
       Case "退出系统"
           Call MenuExit_Click
       Case "重新登录"
           Call MenuUserLogin_Click
       Case "修改密码"
           Call MenuEditPW_Click
       Case "开始考试"
           Call MenuStartExam_Click
End Select
End Sub



Private Sub Winsock1_Close(Index As Integer)
    
      For i = 1 To LVStudentState.ListItems.Count
        If LVStudentState.ListItems(i).SubItems(3) = Winsock1(Index).RemoteHostIP Then
          LVStudentState.ListItems(i).SubItems(4) = "掉线"
         End If
      Next i
      Unload Winsock1(Index)
End Sub



Private Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Dim IpIndex As Integer
If HostState Then: Exit Sub '判定服务器是否繁忙？
   HostState = True '服务器繁忙
   For i = 1 To Winsock1.Count
      If i = Winsock1.Count Then
         Load Winsock1(i)
         Winsock1(i).Accept requestID
         IpIndex = i
         Exit For
      End If
      If Winsock1(i).State = 0 Then
         Winsock1(i).Accept requestID
         IpIndex = i
         Exit For
      End If
   Next i
   For j = 1 To LVStudentState.ListItems.Count
    If LVStudentState.ListItems(j).SubItems(3) = Winsock1(i).RemoteHostIP Then
       LVStudentState.ListItems(j).SubItems(4) = "正在考试"
        Exit For
     End If
   Next j

   HostState = False
End Sub

Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim Dstring$
Dim Rp As Boolean
Dim Port As String
    Dim Rs As ADODB.Recordset
    Dim Msg$
    Dim SQL$
    Winsock1(Index).GetData Dstring, vbString, bytesTotal
  Select Case Mid(Dstring, 1, 10)
         Case "|StudenID|"
              Winsock1(Index).SendData VerifyStudent(Mid(Dstring, 11, bytesTotal), Winsock1(Index).RemoteHostIP)
         Case "|GetExamI|"
              Winsock1(Index).SendData "|GetExamI|" & FillSubject & " " & FillSubjectValue _
                                                    & " " & SelectSubject & " " & SelectSubjectValue _
                                                    & " " & MultiSelectSubject & " " & MultiSelectSubjectValue _
                                                    & " " & OperationSubject & " " & ExamTime _
                                                    & " " & FileLen(App.Path & "\examktl.dll")
         Case "|ExamOver|"
              Winsock1(Index).SendData SavePointToStudent(Mid(Dstring, 11, bytesTotal))
              For i = 1 To LVStudentState.ListItems.Count
                 If LVStudentState.ListItems(i).SubItems(3) = Winsock1(Index).RemoteHostIP Then
                     LVStudentState.ListItems(i).SubItems(4) = "交卷"
                 End If
              Next i
'已取消
'         Case "|ExamSave|"
'              Winsock1(Index).SendData SavePointToStudent(Mid(Dstring, 11, bytesTotal), "Save")

         Case "|CheatMsg|"
                    DBName = StudentDB
                    SQL = "select * from Student where ID='" & Label5.Caption & "'"
                
                    Set Rs = executeSQL(SQL, Msg, DBName)
                     
                    Rs.Fields(4) = "作弊处理"
                    Rs.Update
                         For i = 1 To LVStudentState.ListItems.Count
                            If LVStudentState.ListItems(i).SubItems(3) = Winsock1(Index).RemoteHostIP Then
                               LVStudentState.ListItems(i).SubItems(4) = "作弊处理"
                            End If
                         Next i
         Case "|SendFile|"
                 Randomize
                  Rp = True
                   Do While Rp
              
                        Port = Int((Rnd * 65534))
                        If Val(Port) < 1000 Then
                           Port = Val(Port) + 1000
                        End If
                        WskFileBind.Close
                    On Error GoTo Already:
                        WskFileBind.Bind Port, Text3.Text
                        WskFileBind.Close
                         
                         
                         If Dir(App.Path & "\WskSend.dll") = Empty Then
                            MsgBox "缺少WskSend.dll", vbInformation
                         End If
                         Shell App.Path & "\WskSend.dll " & Text3.Text & " " & Port & " " & "examktl.dll"
            '             WskFileComm(0).Accept requestID
            '             Timer1.Enabled = True
                         Winsock1(Index).SendData "|SendFile|" & Port
                        Exit Do
Already: '------------------------------
                    Loop

  End Select
              
End Sub

'Private Sub WskFileBind_ConnectionRequest(ByVal requestID As Long)
'Dim IpIndex As Integer
'If HostFileState Then: Exit Sub '判定服务器是否繁忙？如果繁忙则拒绝请求
'   Rp = True
'   Timer1.Enabled = False
'   HostFileState = True '服务器繁忙
'   WskFileComm(0).Close
''   For i = 1 To WskFileComm.Count
''      If i = WskFileComm.Count Then
''         Load WskFileComm(i)
''          WskFileComm(i).Accept requestID
''         IpIndex = i
''         Exit For
''      End If
''      If WskFileComm(i).State = 0 Then
''          WskFileComm(i).Accept requestID
''         IpIndex = i
''         Exit For
''      End If
''   Next i
'     Do While Rp
'            Port = Str(Int((Rnd * 65534)))
'            If Val(Port) < 1000 Then
'               Port = Port + 1000
'            End If
'        On Error GoTo Already:
'            WskFileComm(0).Bind Port, Text3.Text
'             Shell App.Path & "\WskSend.exe " & Text3.Text & " " & Port & " " & "examktl.dll"
''             WskFileComm(0).Accept requestID
''             Timer1.Enabled = True
'            Exit Do
'Already:
'
'     Loop
'
'End Sub
''
'Private Sub WskFileComm_DataArrival(Index As Integer, ByVal bytesTotal As Long)
' Dim fileBuff() As Byte
'Dim FileNumeber
'Dim Dstring
'
'
'
'      FileNumber = FreeFile
'      WskFileComm(Index).GetData Dstring, vbString, bytesTotal
'            '---------------------------------------------
'  Select Case Mid(Dstring, 1, 10)
'         Case "|SendFile|"
'             FileNumber = FreeFile
'             Open (App.Path & "\examktl.dll") For Binary Access Read As #FileNumber
'             ReDim fileBuff(LOF(FileNumber)) As Byte
'               Get #FileNumber, 1, fileBuff
'                WskFileComm(Index).SendData (fileBuff)
'             Close #FileNumber
'        Case "|DownFile|"
'             HostFileState = False '服务器设为空闲
' End Select
'End Sub