modclient.bas

自己用vb开发的局域网考试系统

Attribute VB_Name = "Module1"
Option Explicit
Global StudentID As String '存储登机考生ID号
'Global StudentNAME As String '存储登记考生姓名
'在托盘上加图标
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const NIM_MODIFY = &H1
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Type NOTIFYICONDATA
        cbSize As Long 'NOTIFYICONDATA类型的字节数
        hwnd As Long '与状态区图标联系的窗口句柄
        uID As Long '自定义的任务栏图标句柄
        uFlags As Long '标识类型中其它成员是否有效
        uCallbackMessage As Long '系统返回消息的标识，对于处理状态区的鼠标的事件很有用
        hIcon As Long '使用的图标的句柄
        szTip As String * 64 '提示字符串，最长为64个字符
End Type
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public tnid As NOTIFYICONDATA
Public Const GWL_WNDPROC = -4
Global lpPrevWndProc As Long
Global gHW As Long

'隐藏本任务

Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0

'注册表操作
Private Const REG_SZ = 1
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

'移动没标题的窗口
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_SYSCOMMAND = &H112
Public Const SC_MOVE = &HF010&
Public Const HTCAPTION = 2

Global ConnString As String '连接试题库数据库的字符串
Global LocalConn As Connection '连接本地数据库的连接

'读写INI文件的API函数
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
Global InIpath As String 'ini文件路径
'Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'''''
'自动运行设定的程序
Function AutoRun(AutoName As String, FileName As String)
Dim hKey As Long
RegOpenKey HKEY_LOCAL_MACHINE, "Software\Microsoft\windows\CurrentVersion\Run", hKey
RegSetValueEx hKey, AutoName, 0, REG_SZ, ByVal FileName, Len(FileName)
RegCloseKey hKey
End Function
'隐藏本任务
'To remove your program from the Ctrl+Alt+Delete list, call the MakeMeService procedure:
Public Sub RemoveProgramFromList()
    Dim lngProcessID As Long
    Dim lngReturn As Long
    
    lngProcessID = GetCurrentProcessId()
    lngReturn = RegisterServiceProcess(lngProcessID, RSP_SIMPLE_SERVICE)
End Sub
'显示本任务

'To restore your application to the Ctrl+Alt+Delete list, call the UnMakeMeService procedure:
Public Sub AddProgramToList()
    Dim lngProcessID As Long
    Dim lngReturn As Long
    
    lngProcessID = GetCurrentProcessId()
    lngReturn = RegisterServiceProcess(lngProcessID, RSP_UNREGISTER_SERVICE)
End Sub

'查找给定目录的上一级目录
Function GetPrvPath(ByVal Path As String) As String
  Dim i As Integer
  Dim Tstr As String
  For i = Len(Path) To 1 Step -1
     Tstr = Mid(Path, i, 1)
     If Tstr = "\" Then
       GetPrvPath = Left(Path, i - 1)
       Exit Function
     End If
  Next i
  
End Function
'由ID值求他的对应题目的分数或者答案等
Function GetNeedByID(ByVal IDStr As String, ByVal NeedStr As String, ByVal IDSplitStr As String, ByVal NeedSplitStr As String, ByVal ID As Long) As String
    If IDStr = "" Or NeedStr = "" Then
       GetNeedByID = ""
       Exit Function
    End If
    Dim i As Long
    Dim IDArr() As String
    Dim NeeDArr() As String
    IDArr = Split(IDStr, IDSplitStr)
    NeeDArr = Split(NeedStr, NeedSplitStr)
    For i = 0 To UBound(IDArr)
      If ID = Val(IDArr(i)) Then
         GetNeedByID = NeeDArr(i)
         Exit Function
      End If
    Next i
    GetNeedByID = ""
End Function
'修改后加入所有题型的，直接传递成绩ID号
Sub CreateHTML(ByVal FileName As String, ByVal ID As Long)
  Dim adoRS As Recordset
  Set adoRS = New Recordset
  adoRS.CursorLocation = adUseClient

  Dim adoSJRs As Recordset
  Set adoSJRs = New Recordset
  adoSJRs.CursorLocation = adUseClient

  Dim adoTempRs As Recordset '处理除选择题以外的题型
  Set adoTempRs = New Recordset
  adoTempRs.CursorLocation = adUseClient

  Dim Title As String '试卷标题
  Dim sql As String
  Dim Number As Integer
  Dim i As Integer
   '保存头字符串
  Dim TempStr As String
  Dim XuanZeStr As String '保存选择题的字符串
  Dim TianKongStr As String '保存填空题的字符串
  Dim PanDuanStr As String '保存判断题的字符串
  Dim WenDaStr As String '保存问答题字符串
  Dim ZuoWenStr As String '作文题的
  Dim ScoreIDStr As String '保存成绩表里的题目ID
  Dim TestIDStr As String '保存试卷表里的题目ID的字符串
  Dim TMScoreStr As String '保存题目的分数的字符串
  Dim DScoreStr As String '保存成绩的分数字符串
  Dim KSDaAnStr As String '保存成绩表的考生答案字符串
  Dim OneDaAn As String '保存学生做的一道题的答案
  Dim TempArr() As String '用于产生临时数组
  sql = "select test.title,score.danxuan,score.danxuanid,score.danxuans"
  sql = sql + ",score.duoxuan,score.duoxuanid,score.duoxuans"
  sql = sql + ",test.danxuan,test.danxuans,test.duoxuan,test.duoxuans"
  sql = sql + ",test.tiankong,test.tiankongs,test.panduan,test.panduans,test.wenda,test.wendas"
  sql = sql + ",test.zuowen,test.zuowens from score,test where score.testid=test.id and score.id=" & ID
  adoRS.Open sql, ConnString, adOpenStatic, adLockOptimistic
  Title = adoRS.Fields(0).Value
  TempStr = "<p align=center><b><font face='楷体_GB2312' size=5>" + Title + "</font></b></p><hr>" + vbCrLf
  TempStr = TempStr + "<div align=center><table border=0 width=94% cellpadding=2><TR><TD>" + vbCrLf
  '单选题
  If adoRS.Fields(2).Value <> "" Then
     '查询
     sql = "select id,wenti,xuanze1,xuanze2,xuanze3,xuanze4,daan from question where id in (" + adoRS.Fields(2).Value + ")"
     adoSJRs.Open sql, ConnString, adOpenStatic, adLockOptimistic
     '开始产生字符串
     XuanZeStr = XuanZeStr + "<br><FONT size=2 COLOR=#FF0000>一、单选题</FONT><br>" + vbCrLf
     Number = 0
     '付给字符串
     ScoreIDStr = adoRS.Fields(2).Value
     TestIDStr = adoRS.Fields(7).Value
     TMScoreStr = adoRS.Fields(8).Value
     DScoreStr = adoRS.Fields(3).Value
     KSDaAnStr = adoRS.Fields(1).Value
     Do While Not adoSJRs.EOF
       Number = Number + 1
       XuanZeStr = XuanZeStr + "<FONT size=2 COLOR=#0000FF>" + Str(Number) + "、" + adoSJRs.Fields("wenti") + "(" + GetNeedByID(TestIDStr, TMScoreStr, ",", ",", adoSJRs.Fields("id").Value) + "分)</FONT>" + vbCrLf
       XuanZeStr = XuanZeStr + "<FONT size=2 COLOR=#0000FF><ul TYPE=A>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze1").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze2").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze3").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze4").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "</ul></font>" + vbCrLf
       OneDaAn = GetNeedByID(ScoreIDStr, KSDaAnStr, ",", "/", adoSJRs.Fields("id").Value)
       If adoSJRs.Fields("daan").Value = OneDaAn Then
         XuanZeStr = XuanZeStr + "<font color=#ff0000>正确！</font>" + "标准答案：" + "<font color=#ff0000>" + adoSJRs.Fields("daan").Value + "</font><br>" + vbCrLf
       Else
         XuanZeStr = XuanZeStr + "<font color=#ff0000>错误！</font>" + "您的答案：" + "<font color=#ff0000>" + OneDaAn + "</font>" + " 标准答案：" + "<font color=#ff0000>" + adoSJRs.Fields("daan").Value + "</font><br>" + vbCrLf
       End If
       XuanZeStr = XuanZeStr + "你的得分：<font color=#ff0000>" + GetNeedByID(ScoreIDStr, DScoreStr, ",", ",", adoSJRs.Fields("id").Value) + "分</font><br>" + vbCrLf
       adoSJRs.MoveNext
     Loop
  End If
  
  '多选题
  adoSJRs.Close
  If adoRS.Fields(5).Value <> "" Then
     '查询
     sql = "select id,wenti,xuanze1,xuanze2,xuanze3,xuanze4,daan from question where id in (" + adoRS.Fields(5).Value + ")"
     adoSJRs.Open sql, ConnString, adOpenStatic, adLockOptimistic
     '开始产生字符串
     XuanZeStr = XuanZeStr + "<br><FONT size=2 COLOR=#FF0000>二、多选题</FONT><br>" + vbCrLf
     Number = 0
     '付给字符串
     ScoreIDStr = adoRS.Fields(5).Value
     TestIDStr = adoRS.Fields(9).Value
     TMScoreStr = adoRS.Fields(10).Value
     DScoreStr = adoRS.Fields(6).Value
     KSDaAnStr = adoRS.Fields(4).Value
     Do While Not adoSJRs.EOF
       Number = Number + 1
       XuanZeStr = XuanZeStr + "<FONT size=2 COLOR=#0000FF>" + Str(Number) + "、" + adoSJRs.Fields("wenti") + "(" + GetNeedByID(TestIDStr, TMScoreStr, ",", ",", adoSJRs.Fields("id").Value) + "分)</FONT>" + vbCrLf
       XuanZeStr = XuanZeStr + "<FONT size=2 COLOR=#0000FF><ul TYPE=A>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze1").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze2").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze3").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "<li>" + adoSJRs.Fields("xuanze4").Value + "</li>" + vbCrLf
       XuanZeStr = XuanZeStr + "</ul></font>" + vbCrLf
       OneDaAn = GetNeedByID(ScoreIDStr, KSDaAnStr, ",", "/", adoSJRs.Fields("id").Value)
       If adoSJRs.Fields("daan").Value = OneDaAn Then
         XuanZeStr = XuanZeStr + "<font color=#ff0000>正确！</font>" + "标准答案：" + "<font color=#ff0000>" + adoSJRs.Fields("daan").Value + "</font><br>" + vbCrLf
       Else
         XuanZeStr = XuanZeStr + "<font color=#ff0000>错误！</font>" + "您的答案：" + "<font color=#ff0000>" + OneDaAn + "</font>" + " 标准答案：" + "<font color=#ff0000>" + adoSJRs.Fields("daan").Value + "</font><br>" + vbCrLf
       End If
       XuanZeStr = XuanZeStr + "你的得分：<font color=#ff0000>" + GetNeedByID(ScoreIDStr, DScoreStr, ",", ",", adoSJRs.Fields("id").Value) + "分</font><br>" + vbCrLf
       adoSJRs.MoveNext
     Loop
  End If
  
'  '填空题
'  adoSJRs.Close
'  sql = "select * from scoreTK where id=" & ID
'  '打开成绩表里的填空题
'  adoTempRs.Open sql, ConnString, adOpenStatic, adLockOptimistic
'  If adoTempRs.Fields("tiankongid").Value <> "" Then
'     '查询
'     sql = "select id,wenti,daan from questionTK where id in (" + adoTempRs.Fields("tiankongid").Value + ")"
'     adoSJRs.Open sql, ConnString, adOpenStatic, adLockOptimistic
'     '开始产生字符串
'     TianKongStr = TianKongStr + "<br><FONT size=2 COLOR=#FF0000>三、填空题</FONT><br>" + vbCrLf
'     Number = 0
'     '付给字符串