module1.bas

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

Attribute VB_Name = "CommonModule"
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long



Public UserLogin As Boolean

Public FillSubject() As Long

Public SingleChoiceSubject() As Long

Public MultiChoiceSubject() As Long

Public OperationSubject() As Long
'--------------------------------------

Public FillSelectQuestion() As String '填空选择答案

'Public TestSubject() As Long

Public SingleSelectQuestion() As String '单选选择答案
'Public SelectQuestion() As String

Public MultiSelectQuestion() As String '多选选择答案
'------------------------------------------

Public FillRightQuestion() As String '填空正确答案


Public SingleRightQuestion() As String


Public MultiRightQuestion() As String


'Public QuestionRight() As String




Public FillSubjectRight() As Boolean
Public SingleSelectRight() As Boolean
Public MultiSelectRight() As Boolean
'Public SelectRight() As Boolean

'------------------------------------


Public ServerIP As String '服务器地址
'考试信息 操作题 选择题 及考试时间
'Public SelectSubject$
'Public SelectSubjectValue$
'Public OperationSubject$
'Public ExamTime$

Public FillSubjectCount$
Public FillSubjectValue$
Public SingleChoiceSubjectCount$
Public SingleChoiceSubjectValue$
Public MultiChoiceSubjectCount$
Public MultiChoiceSubjectValue$
Public OperationSubjectCount$
Public OperationSubjectValue$
Public ExamTime$




Type StudentInfo
   sId As String
   sName As String
End Type
Public StInfo As StudentInfo
Public FailedData As String '需要再次发送的数据 如与服务器断开连接时记录下需要发送的数据
Public DownFileLenCount As Long
Public ZongFeng As Double

Public Function executeSQL(ByVal SQL As String, msgstring As String) As ADODB.Recordset
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
On Error GoTo executeSQL_error
Set cnn = New ADODB.Connection
cnn.CursorLocation = adUseClient
cnn.Open connectstring

 Set rst = New ADODB.Recordset
rst.Open SQL, cnn, adOpenStatic, adLockOptimistic

Set executeSQL = rst
msgstring = "查询到" & rst.RecordCount & _
"条记录"

Set rst = Nothing
Set cnn = Nothing
Exit Function
executeSQL_error:
msgstring = "查询错误;" & _
Err.Description
Set rst = Nothing
Set cnn = Nothing
End Function

Public Function connectstring() As String
connectstring = "PROVIDER=MSDataShape;Data PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=" & App.Path & "\examktl.dll"
End Function

Public Sub GetExamInfo(CData As String)
Dim Temp() As String
 Temp = Split(CData)

 FillSubjectCount = Temp(0)
 FillSubjectValue = Temp(1)
 SingleChoiceSubjectCount = Temp(2)
 SingleChoiceSubjectValue = Temp(3)
 MultiChoiceSubjectCount = Temp(4)
 MultiChoiceSubjectValue = Temp(5)
  OperationSubjectCount = Temp(6)
 ExamTime = Temp(7)
 DownFileLenCount = CLng(Temp(8))



End Sub
Public Sub ConnectServer()
    FrmMain.Winsock1.Close
    FrmMain.Winsock1.Connect Trim(ServerIP), "10088"

End Sub
Public Sub OverExamSetup()
           UserLogin = False
           Kill App.Path & "\ExamBak.bak"
           Kill App.Path & "\examktl.dll"
           Unload FrmBuild
           Unload FrmDownload
           Unload FrmLogin
           Unload FrmSelectTest
           Unload FrmFillTest
           Unload FrmMultiSelectTest
           Unload FrmOperation
           
             ReDim FillSubject(0) As Long
             ReDim SingleChoiceSubject(0) As Long
             ReDim MultiChoiceSubject(0) As Long
             ReDim OperationSubject(0) As Long
         
             ReDim FillSelectQuestion(0) As String
             ReDim SingleSelectQuestion(0) As String
             ReDim MultiSelectQuestion(0) As String
        
             ReDim FillRightQuestion(0) As String
             ReDim SingleRightQuestion(0) As String
             ReDim MultiRightQuestion(0) As String
             
             ReDim FillSubjectRight(0) As Boolean
             ReDim SingleSelectRight(0) As Boolean
             ReDim MultiSelectRight(0) As Boolean
        
End Sub

Public Function JieMi(Dstr As String, Dkey As String)
Dim Pos As Integer, NewStr As String
Dim iChar As String
Dim pKey As String
Pos = 1
For i = 1 To Len(Dstr)
    iChar = Mid(Dstr, i, 1)
    pKey = Mid(Dkey, Pos, 1)
    If Asc(iChar) = 128 Then
        NewStr = NewStr & pKey
    Else
        NewStr = NewStr & Chr(Asc(iChar) Xor Asc(pKey))
    End If
    If Pos = Len(Dkey) Then Pos = 0
    Pos = Pos + 1
Next i
  JieMi = NewStr
End Function

Sub CountZongFeng(ExamOver As Boolean)
Dim L As Integer
Dim FSelect() As String
Dim FRight() As String
L = 0
ZongFeng = 0
'----------------------------填空题总分----------------------------
   
    
    For i = 0 To UBound(FillSubject) - 1
        If FillSelectQuestion(i) = Empty Then
           L = L + 1
        End If
        FSelect = Split(FillSelectQuestion(i))
        FRight = Split(FillRightQuestion(i))
        
        For j = 0 To UBound(FSelect) - 1
            For h = 0 To UBound(FRight) - 1
              If UCase$(Trim$(FSelect(j))) = UCase$(Trim$(FRight(h))) Then
                 ZongFeng = ZongFeng + Val(FillSubjectValue)
              End If
            Next h
        Next j
    Next i
    
 If L > 0 Then
  If MsgBox("你还有 " & L & " 填空题未做！是否要放弃", vbInformation + vbYesNo, "警告") = vbNo Then
             Exit Sub
  End If
 End If
'--------------------------------------------------------

L = 0
'----------------------------单项选择总分----------------------------
    For i = 0 To UBound(SingleRightQuestion) - 1
        If SingleSelectQuestion(i) = Empty Then
           L = L + 1
        End If
        If SingleSelectQuestion(i) = SingleRightQuestion(i) And SingleSelectQuestion(i) <> "" Then
           SingleSelectRight(i) = True
        
        Else
           SingleSelectRight(i) = False
         
        End If
    Next i
   If L > 0 Then
    If ExamTime <> 0 Then
        If MsgBox("你还有 " & L & " 单项选择题未做！是否要放弃", vbInformation + vbYesNo, "警告") = vbNo Then
             Exit Sub
        End If
    End If
   End If
    For i = 0 To UBound(SingleSelectRight)
        If SingleSelectRight(i) = True Then
           ZongFeng = ZongFeng + Val(SingleChoiceSubjectValue)
        End If
    Next i
'--------------------------------------------------------

L = 0
'----------------------------多项选择总分----------------------------
    For i = 0 To UBound(MultiRightQuestion) - 1
        If MultiSelectQuestion(i) = Empty Then
           L = L + 1
        End If
        If MultiSelectQuestion(i) = MultiRightQuestion(i) And MultiSelectQuestion(i) <> "" Then
           MultiSelectRight(i) = True
        
        Else
           MultiSelectRight(i) = False
         
        End If
    Next i

      If L > 0 Then
        If MsgBox("你还有 " & L & " 多项选择题未做！是否要放弃", vbInformation + vbYesNo, "警告") = vbNo Then
             Exit Sub
        End If
      End If
    
    For i = 0 To UBound(MultiSelectRight)
        If MultiSelectRight(i) = True Then
           ZongFeng = ZongFeng + Val(MultiChoiceSubjectValue)
        End If
    Next i
'--------------------------------------------------------
    

    
    
    
   If ExamOver = True Then
        If FrmMain.Winsock1.State = 7 Then
            FrmMain.Winsock1.SendData "|ExamOver|" & StInfo.sId & " " & ZongFeng
        Else
            FailedData = "|ExamOver|" & StInfo.sId & " " & ZongFeng
            Call ConnectServer
        End If
   Else
'已取消
'        If FrmMain.Winsock1.State = 7 Then
'            FrmMain.Winsock1.SendData "|ExamSave|" & StInfo.sId & " " & ZongFeng
'        Else
'
'            FailedData = "|ExamSave|" & StInfo.sId & " " & ZongFeng
'            Call ConnectServer
'        End If
   End If
        
End Sub
Function TrimEnd(str As String) As String
   If Asc(Right(str, 1)) = 0 Then
      TrimEnd = Mid(str, 1, Len(str) - 1)
   Else
      TrimEnd = str
   End If
End Function
Function TrimIpSpace(str As String) As String
If InStr(str, Chr(0)) <> 0 Then
   TrimIpSpace = Mid(str, 1, InStr(str, Chr(0)) - 1)
End If
   
End Function