?? modquestion.bas

?? 自己用vb開發(fā)的局域網考試系統(tǒng)
?? 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
'創(chuàng)建成績表網頁
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值，并跳出循環(huán)，若一直匹配，則取大于
'       計數器當前值的最小值作為 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 + -
亚洲欧美第一页_禁久久精品乱码_粉嫩av一区二区三区免费野_久草精品视频

?? modquestion.bas

?? 快捷鍵說明
