📄 modquestion.bas

📁 自己用vb开发的局域网考试系统
💻 BAS
📖 第 1 页 / 共 2 页
字号:
12 下一页
Attribute VB_Name = "Module1"
 
'移动没标题的窗口
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
'让窗口始终在所有窗口上面
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
'让窗口始终在所有窗口上面
Function SetFormTop(hwnd As Long, Top As Boolean)
If Top Then
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
End Function
'创建成绩表网页
Sub CreateScoreTable(ByVal FileName As String, ByVal adoTempRs As Recordset)
   Dim TempStr As String
   TempStr = "<body bgcolor=#FFFFFF>"
   TempStr = TempStr + "<div id=Layer1 style=position:absolute; width:486px; height:41px; z-index:1; left: 131px; top: 24px>"
   TempStr = TempStr + "<table width=485 border=1 cellpadding=0 cellspacing=0>"
   TempStr = TempStr + "<tr align=center>"
   TempStr = TempStr + "<td colspan=3 height=20><b>考号</b></td>"
   TempStr = TempStr + "<td width=17% height=20><b>姓名</b></td>"
   TempStr = TempStr + "<td width=35% height=20><b>科目</b></td>"
   TempStr = TempStr + "<td width=13% height=20><b>成绩</b></td>"
   TempStr = TempStr + "<td width=12% height=20><b>名次</b></td>"
   TempStr = TempStr + "</tr>"
   Do While Not adoTempRs.EOF
      TempStr = TempStr + "<tr align=center>"
      TempStr = TempStr + "<td colspan=3>" + adoTempRs.Fields("考号").Value + "</td>"
      TempStr = TempStr + "<td width=17%>" + adoTempRs.Fields("考生姓名").Value + "</td>"
      TempStr = TempStr + "<td width=35%>" + adoTempRs.Fields("科目").Value + "</td>"
      TempStr = TempStr + "<td width=13%>" & adoTempRs.Fields("考试成绩").Value & "</td>"
      TempStr = TempStr + "<td width=12%>" & adoTempRs.AbsolutePosition & "</td>"
      TempStr = TempStr + "</tr>"
      adoTempRs.MoveNext
   Loop
   TempStr = TempStr + "</table></div></body>"
  Open FileName For Output As #1
    Print #1, TempStr
  Close #1
End Sub

'预览试卷，加入答案,DAView表示是否显示答案
Sub CreateHTML(ByVal FileName As String, ByVal Title As String, ByVal DaView As Boolean, ByVal rsdan As Recordset, ByVal rsduo As Recordset)
', ByVal rsTK As Recordset, ByVal rsPD As Recordset, ByVal rsWD As Recordset, ByVal rsZW As Recordset
  Dim RsStr As String
  Dim Number As Integer
  Dim i As Integer
  Dim Count As Integer
  Dim TempStr As String
  TempStr = "<p align=center><b><font face='楷体_GB2312' size=4>" + Title + "</font></b></p><hr>" + vbCrLf
  TempStr = TempStr + "<div align=center><table border=0 width=90%><TR><TD>" + vbCrLf
  '单选题
  RsStr = ""
  Number = 0
 If Not rsdan.EOF Then
  RsStr = RsStr + "<FONT size=2 COLOR=#FF0000>一、单选题</FONT><br>" + vbCrLf
 End If
 Do While Not rsdan.EOF
  Number = Number + 1
  RsStr = RsStr + "<FONT size=2 COLOR=#0000FF>" + str(Number) + "、" + rsdan.Fields("wenti") + "</FONT>" + vbCrLf
  RsStr = RsStr + "<ul TYPE=A>" + vbCrLf
  RsStr = RsStr + "<li>" + rsdan.Fields("xuanze1").Value + "</li>" + vbCrLf
  RsStr = RsStr + "<li>" + rsdan.Fields("xuanze2").Value + "</li>" + vbCrLf
  RsStr = RsStr + "<li>" + rsdan.Fields("xuanze3").Value + "</li>" + vbCrLf
  RsStr = RsStr + "<li>" + rsdan.Fields("xuanze4").Value + "</li>" + vbCrLf
  RsStr = RsStr + "</ul>" + vbCrLf
  If DaView = True Then RsStr = RsStr + "   答案:<font color=#ff0000>" + rsdan.Fields("daan").Value + "</font><br><br>" + vbCrLf
rsdan.MoveNext
 Loop
 Number = 0
 
 '多选题
 If Not rsduo.EOF Then
   RsStr = RsStr + "<FONT size=2 COLOR =#FF00>二、多选题</FONT><br>" + vbCrLf
 End If
 Do While Not rsduo.EOF
  Number = Number + 1
  RsStr = RsStr + "<FONT size=2 COLOR=#0000FF>" + str(Number) + "、" + rsduo.Fields("wenti") + "</FONT>" + vbCrLf
  RsStr = RsStr + "<ul type=A>" + vbCrLf
  RsStr = RsStr + "<li>" + rsduo.Fields("xuanze1").Value + "</li>" + vbCrLf
  RsStr = RsStr + "<li>" + rsduo.Fields("xuanze2").Value + "</li>" + vbCrLf
  RsStr = RsStr + "<li>" + rsduo.Fields("xuanze3").Value + "</li>" + vbCrLf
  RsStr = RsStr + "<li>" + rsduo.Fields("xuanze4").Value + "</li>" + vbCrLf
  RsStr = RsStr + "</ul>" + vbCrLf
  If DaView = True Then RsStr = RsStr + "   答案:<font color=#ff0000>" + rsduo.Fields("daan").Value + "</font><br><br>" + vbCrLf
rsduo.MoveNext
 Loop

''填空题
'Dim RsStrTK As String
'Dim DaanStr As String
'Dim DaanStrArr() As String
'Number = 0
'If Not rsTK.EOF Then
'  RsStrTK = RsStrTK + "<FONT size=2 COLOR =#FF00>三、填空题</FONT><br>" + vbCrLf
'End If
'Do While Not rsTK.EOF
'  Number = Number + 1
'  RsStrTK = RsStrTK + "<FONT size=2 COLOR=#0000FF>" + str(Number) + "、" + rsTK.Fields("wenti") + "</FONT><br>" + vbCrLf
'  DaanStrArr = Split(rsTK.Fields("daan").Value, "▲▲")
'  DaanStr = ""
'  For i = 0 To UBound(DaanStrArr)
'     DaanStr = DaanStr + "<U>" + DaanStrArr(i) + "</u>、"
'  Next i
'  DaanStr = Left(DaanStr, Len(DaanStr) - 1)
'  If DaView = True Then RsStrTK = RsStrTK + "   答案:<font color=#ff0000>" + DaanStr + "</font><br><br>" + vbCrLf
' rsTK.MoveNext
'Loop
'
''判断题
'Dim RsStrPD As String
'Number = 0
'If Not rsPD.EOF Then
'  RsStrPD = RsStrPD + "<FONT size=2 COLOR =#FF00>四、判断题</FONT><br>" + vbCrLf
'End If
'Do While Not rsPD.EOF
'  Number = Number + 1
'  RsStrPD = RsStrPD + "<FONT size=2 COLOR=#0000FF>" + str(Number) + "、" + rsPD.Fields("wenti") + "</FONT><br>" + vbCrLf
'  If rsPD.Fields("daan").Value = "T" Then
'    DaanStr = "对"
'   Else
'    DaanStr = "错"
'  End If
'  If DaView = True Then RsStrPD = RsStrPD + "   答案:<font color=#ff0000>" + DaanStr + "</font><br><br>" + vbCrLf
' rsPD.MoveNext
'Loop
'
''问答
'Dim RsStrWD As String
'Number = 0
'If Not rsWD.EOF Then
'  RsStrWD = RsStrWD + "<FONT size=2 COLOR =#FF00>五、问答题</FONT><br>" + vbCrLf
'End If
'Do While Not rsWD.EOF
'  Number = Number + 1
'  RsStrWD = RsStrWD + "<FONT size=2 COLOR=#0000FF>" + str(Number) + "、" + rsWD.Fields("wenti") + "</FONT><br>" + vbCrLf
'  DaanStr = rsWD.Fields("daan").Value
'  If DaView = True Then RsStrWD = RsStrWD + "   评分标准:<font color=#ff0000>" + DaanStr + "</font><br><br>" + vbCrLf
' rsWD.MoveNext
'Loop
'
''作文
'Dim RsStrZW As String
'Number = 0
'If Not rsZW.EOF Then
'  RsStrZW = RsStrZW + "<FONT size=2 COLOR =#FF00>六、作文</FONT><br>" + vbCrLf
'End If
'Do While Not rsZW.EOF
'  Number = Number + 1
'  RsStrZW = RsStrZW + "<FONT size=2 COLOR=#0000FF>" + str(Number) + "、" + rsZW.Fields("wenti") + "</FONT><br>" + vbCrLf
'  DaanStr = rsZW.Fields("daan").Value
'  If DaView = True Then RsStrZW = RsStrZW + "   评分标准:<font color=#ff0000>" + DaanStr + "</font><br><br>" + vbCrLf
' rsZW.MoveNext
'Loop
'
'RsStrZW = RsStrZW + "</TD></TR></table></div>" + vbCrLf
Open FileName For Output As #1
    Print #1, TempStr + RsStr
'    + RsStrTK + RsStrPD + RsStrWD + RsStrZW
  Close #1
End Sub

'应为自动ID不能处理删除了的记录的ID问题，现在写一函数来模拟自动ID
Function GetAutoID(ByVal TableName As String) As Long
  Dim i As Long
  Dim longID As Long
  Dim adoRs As Recordset
  Set adoRs = New Recordset
  adoRs.Open "select id from " + TableName + " ORDER BY id", adoCn, adOpenStatic, adLockOptimistic
  longID = 1
  If Not adoRs.EOF Then
        adoRs.MoveLast
        adoRs.MoveFirst
        For i = 1 To adoRs.RecordCount
'-------------------------------------------------------+
' 获取空余最小 ID 号:
'    从 1 开始搜索，若记录计数器 x 不等于 ID 字段值 ，
'  则取该序号作为 ID值，并跳出循环，若一直匹配，则取大于
'       计数器当前值的最小值作为 ID值
'--------------------------------------------------------
        If i <> adoRs.Fields(0) Then
             longID = i
             Exit For
        End If
        longID = i + 1
        adoRs.MoveNext
        Next i
  End If
  Set adoRs = Nothing
 GetAutoID = longID
End Function
'数字到字符串的转化（str函数会产生空格）
Function Int2Str(ByVal IntLong As Variant) As String
  Int2Str = Trim(str(IntLong))
End Function
'由车间序号转化成入职年
Function Num2Year(ByVal Num As Integer) As Integer
  Dim NewYear As Long, NewMon As Long
  Dim YearNum As Integer
  NewYear = Year(Date)
  NewMon = Month(Date)
  '9月份以后升一级
  YearNum = NewYear - Num
  If NewMon >= 8 Then
    YearNum = NewYear - Num + 1
  End If
  Num2Year = YearNum
End Function

'由入职年转化成车间序号
Function Year2Num(ByVal YearNum As Integer) As Integer
  Dim NewYear As Long, NewMon As Long
  Dim Num As Integer
  NewYear = Year(Date)
  NewMon = Month(Date)
  Num = NewYear - YearNum
  '9月份以后升一级
  If NewMon >= 8 Then
    Num = Num + 1
  End If
  Year2Num = Num
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 CreateScoreHTML(ByVal FileName As String, ByVal ID As Long)
  Dim adoRs As Recordset
  Set adoRs = New Recordset
  Dim adoSJRs As Recordset
  Set adoSJRs = New Recordset
  Dim adoTempRs As Recordset '处理除选择题以外的题型
  Set adoTempRs = New Recordset
  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 '保存题目的分数的字符串
12 下一页
💿 文件大小 806 K
👤 上传用户 junglili
📂 所属分类 SQL Server
🏷️ 相关标签

#局域网
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -