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 WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long



'数据库名 学生信息库及题目信息库
Public DBName$
Public Const StudentDB$ = "exmext.dll"
Public Const ChoiceExerciseDB$ = "examktl.dll"
Public Const UserDB$ = "examyh.dll"

'Public Const SourceKey$ = "A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z 1 2 3 4 5 6 7 8 9 0"
                          '"2 3 f   e   0         b  1 4 c  5 a    6    d           7       8   9     z
'Public Const DestinationKey$ = "2 3 a C B "

Public INIFilePath$ '系统当前路径



'考试信息 操作题 选择题 及考试时间
'Public SelectSubject$
'Public SelectSubjectValue$
'Public OperationSubject$
'Public OperationSubjectValue$
'Public ExamTime$

Public FillSubject$
Public FillSubjectValue$
Public SelectSubject$
Public SelectSubjectValue$
Public MultiSelectSubject$
Public MultiSelectSubjectValue$
Public OperationSubject$
Public OperationSubjectValue$
Public ExamTime$



Public UserType As String
Public UserName As String

Public Function executeSQL(ByVal SQL As String, msgstring As String, DBN 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 & "\" & DBN
     Set rst = New ADODB.Recordset
      rst.Open SQL, cnn, adOpenStatic, adLockOptimistic
      Set executeSQL = rst
      If rst.RecordCount <> 0 Then
         msgstring = "查询正确"
      End If
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
End Function


Public Function VerifyStudent(StudentID As String, StudentIP As String) As String
    Dim Rs As ADODB.Recordset
    Dim SubViewItem As ListItem
    Dim Msg$
    Dim SQL$
    
    DBName = StudentDB
    SQL = "select * from Student where ID='" & StudentID & "'"

Set Rs = executeSQL(SQL, Msg, DBName)

If Msg = "查询正确" Then
        If Rs.Fields(6) = "1" Then
           VerifyStudent = "|StudenEr|"
           Exit Function
        End If
        
     Set SubViewItem = FrmMain.LVStudentState.ListItems.Add(, , Mid(StudentIP, InStrRev(StudentIP, ".") + 1, Len(StudentIP)))
       SubViewItem.SubItems(1) = StudentID
       SubViewItem.SubItems(2) = Rs.Fields(2)
       SubViewItem.SubItems(3) = StudentIP
       SubViewItem.SubItems(4) = "正在考试"

     VerifyStudent = "|StudenOk|" & Rs.Fields(2)


Else
    VerifyStudent = "|StudenEr|"
End If
End Function

Public Function SavePointToStudent(StudentInfo As String, Optional ExamOver As String) As String
    Dim Rs As ADODB.Recordset
    Dim SubViewItem As ListItem
    Dim temp() As String
    Dim Msg$
    Dim SQL$
    temp = Split(StudentInfo)

    DBName = StudentDB
SQL = "select * from Student where ID='" & TrimEnd(temp(0)) & "'"

Set Rs = executeSQL(SQL, Msg, DBName)

If Msg = "查询正确" Then
'    If ExamOver = "Over" Then
     Rs.Fields(4) = temp(1)
     Rs.Fields(6) = "1"
     Rs.Update
     SavePointToStudent = "|EXOverOK|"
     Set Rs = Nothing
'    Else
'     Rs.Fields(4) = temp(1)
'     Rs.Update
'    End If
Else
'      If ExamOver = "Over" Then
      SavePointToStudent = "|EXOverEr|"
     Set Rs = Nothing

'      End If
End If
End Function

Function TrimEnd(Dstr As String) As String
   If Asc(Right(Dstr, 1)) = 0 Then
      TrimEnd = Mid(Dstr, 1, Len(Dstr) - 1)
   Else
      TrimEnd = Dstr
   End If
End Function


Public Function JiaMi(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 iChar = pKey Then
     NewStr = NewStr & Chr(128)
     Else
     NewStr = NewStr & Chr(Asc(iChar) Xor Asc(pKey))
     End If
     If Pos = Len(Dkey) Then Pos = 0
     Pos = Pos + 1
      
   Next i
  JiaMi = NewStr
   
End Function
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