www.pudn.com > chap07.rar > modMain.bas
Attribute VB_Name = "modMain"
Option Explicit
'系统标题
Global Const GS_SYSTEMTITLE As String = "机动车驾驶员模拟考试系统"
'以下用于记录注册表信息
Global Const GS_REGISTRY_APPNAME As String = "JTTEST"
Global Const GS_REGISTRY_SECTION_TOOLBAR As String = "Toolbar"
Global Const GS_REGISTRY_SECTION_OPTIONS As String = "Options"
'数据库路径及数据库、连接字符串
Global GS_DATABASE_PATH As String '数据库目录
Global GS_DATABASE_STRING As String '数据库连接字符串
'------------------
Global Const GS_DATABASE_PROVIDER As String = "Microsoft.Jet.OLEDB.3.51"
Global Const GS_DATABASE_FILENAME As String = "tk.mdb" '数据库名
Global Const GS_DATABASE_PREFACE As String = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source="
Global gadoCONN As ADODB.Connection '数据库连接
Global gfrmMain As Form '主窗口
'API
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
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 Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long
'放在模块声明中?需要用到的常数为
Public Const HH_DISPLAY_INDEX = 2
Public Const HH_DISPLAY_TOC = 1
Public Const HH_DISPLAY_TOPIC = 0
'图片显示方式
Global Const GL_DISPLAY_CENTER As Long = 0
Global Const GL_DISPLAY_TILE As Long = 1
Global Const GL_DISPLAY_STRETCH As Long = 2
'used in SetWindowPos
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_TOPMOST = -1
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type USERINFO
Zh As String '帐号
MC As String '名称
LX As Integer '用户类型0 - 系统管理员;1 - 考生
End Type
'当前登录用户的信息
Global gUserInfo As USERINFO
'启动主程序
Sub Main()
On Error GoTo ErrHandler
Dim i As Long
Dim frm As Form
Dim frmLg As frmLogin
Dim begtt
'--------------------------------
'1:显示splash
'-----------------------------------
Screen.MousePointer = 11
Set frm = New frmSplash
DoEvents '加速显示
Load frm
frm.Refresh '加速显示
frm.Show
DoEvents '加速显示
begtt = Timer '记录当前时间
'--------------------------------------
'2:连接数据库等信息
'------------------------------------------
'设置数据库路径
GS_DATABASE_PATH = GetAppPath() & "data\" '真正的数据库路径"
'设置数据库连接字符串
GS_DATABASE_STRING = GS_DATABASE_PREFACE & GS_DATABASE_PATH & GS_DATABASE_FILENAME & ";Jet OLEDB:Database Password=123456"
'-----------------------------------------
'3:连接数据库----------------
Set gadoCONN = New ADODB.Connection
With gadoCONN
.CursorLocation = adUseClient
.ConnectionString = GS_DATABASE_STRING
.Open
End With
'----------------------------------------------
'5:测试splash是否显示了2秒，如果没有，则继续显示
'---------------------------------------------
While Timer < begtt + 1
DoEvents
Wend
'------------------------------------------------
'6:卸载splash
'-------------------------------------------------
frm.Hide
Screen.MousePointer = 0
'--------------------------------------------
'4:系统登录
'--------------------------------------------
Set frmLg = New frmLogin
frmLg.ADOConnection = gadoCONN
frmLg.Title = GS_SYSTEMTITLE
Load frmLg
frmLg.Show vbModal
'---------------------------------------------
If frmLg.IsCancelled Then
'断开数据库连接
If Not gadoCONN Is Nothing Then
If gadoCONN.State = adStateOpen Then
gadoCONN.Close
End If
Set gadoCONN = Nothing
End If
'------------------------
Unload frm
'-------------------------
End
Else
gUserInfo.Zh = frmLg.Zh
gUserInfo.MC = frmLg.MC
gUserInfo.LX = frmLg.LX
End If
Screen.MousePointer = 11
frm.Show
DoEvents
'-------------------------------------------------------
Select Case gUserInfo.LX '用户类型
Case 0 '系统管理员
'5:显示主窗口
Set gfrmMain = New frmManager
'设置主窗口的标题
gfrmMain.Title = GS_SYSTEMTITLE
Load gfrmMain
gfrmMain.Show
Case 1 '考生
Set gfrmMain = New frmKS
Load gfrmMain
gfrmMain.Show
End Select
'--------------------------------------------------------
While Timer < begtt + 2
DoEvents
Wend
Unload frm
Screen.MousePointer = 0
Exit Sub
ErrHandler:
ErrMessageBox "Main()", "启动过程出错"
'close all sub forms
For i = Forms.Count - 1 To 1 Step -1
Unload Forms(i)
Next
'
'断开数据库连接
If Not gadoCONN Is Nothing Then
If gadoCONN.State = adStateOpen Then
gadoCONN.Close
End If
Set gadoCONN = Nothing
End If
'-------------------------------------------------------
Screen.MousePointer = 0
'
End
End Sub
'this function get the workarea of windows in spite of the taskbar
Public Function GetWorkArea() As RECT
Dim theArea As RECT
Dim tmpVal As Long
tmpVal = SystemParametersInfo(48, 0, theArea, 0)
GetWorkArea = theArea
End Function
'错误处理函数
Public Sub ErrMessageBox(ByVal sPrompt As String, ByVal sTitle As String)
Dim msg As String
Dim ErrMsg As String
'报告错误
ErrMsg = "错误#" & CStr(Err.Number) & "：" & Err.Description
msg = sPrompt & vbCrLf & ErrMsg
MsgBox msg, vbOKOnly + vbInformation, sTitle
msg = sPrompt & vbCrLf & ErrMsg
'将错误记录添加入系统日志
'Call WriteToLog(msg)
'清除错误记录
Err.Clear
End Sub
'将Null转换成0
Public Function ToLong(ByVal val As Variant) As Long
If IsNull(val) Then
ToLong = 0
Else
ToLong = CLng(val)
End If
End Function
'将Null转换成0
Public Function ToInteger(ByVal val As Variant) As Integer
If IsNull(val) Then
ToInteger = 0
Else
ToInteger = CInt(val)
End If
End Function
'获取应用程序所在路径，以"\"结尾
Public Function GetAppPath()
If Right(App.Path, 1) <> "\" Then
GetAppPath = App.Path & "\"
Else
GetAppPath = App.Path
End If
End Function
'获取Windows目录,以"\"结尾
Public Function GetWindowsPath() As String
Dim sWinPath As String
Dim lh As Long
lh = 100
sWinPath = String$(lh, 0)
GetWindowsDirectory sWinPath, lh
sWinPath = TruncateStr(Trim(sWinPath))
If Right(sWinPath, 1) <> "\" Then
sWinPath = sWinPath & "\"
End If
GetWindowsPath = sWinPath
End Function
'将以'\0'结尾的string取前面的
Public Function TruncateStr(ByVal szStr As String) As String
Dim pos As Long
pos = InStr(1, szStr, Chr(0), vbTextCompare)
If pos >= 1 Then
TruncateStr = Trim(Left(szStr, pos - 1))
Else
TruncateStr = Trim(szStr)
End If
End Function
'--------------------------------------------------------------------
'图片以居中、平铺、拉伸显示(可以用于预览)
'参数说明：
'realWidth:实际将要显示区域的宽度
'realHeight:实际将要显示区域的高度
'srcPicture:存在实际的图片大小
'destPicture:用来存放最终显示的图片
'(可以是预览区域，这时destPicture要小于srcWidth和srcHeight，
'也可以是实际区域，这时destPicture与srcWidth和srcHeight大小相同
'
Public Sub PaintImage(ByVal realWidth As Integer, ByVal realHeight As Integer, _
srcPicture As PictureBox, _
destPicture As PictureBox, _
ByVal lDisplayStyle As Long)
Dim dw_pic As Single
Dim dh_pic As Single
Dim x1 As Integer
Dim y1 As Integer
Dim iCt As Long
Dim jCt As Long
Dim i As Long
Dim j As Long
'计算缩放后的图片大小
srcPicture.AutoSize = True
dw_pic = srcPicture.ScaleWidth * destPicture.ScaleWidth / realWidth
dh_pic = srcPicture.ScaleHeight * destPicture.ScaleHeight / realHeight
'根据显示方式的不同，显示图片
Select Case lDisplayStyle
Case GL_DISPLAY_CENTER '居中
x1 = (destPicture.ScaleWidth - dw_pic) / 2
y1 = (destPicture.ScaleHeight - dh_pic) / 2
destPicture = LoadPicture()
destPicture.PaintPicture srcPicture.Picture, x1, y1, dw_pic, dh_pic, 0, 0, srcPicture.ScaleWidth, srcPicture.ScaleHeight
Case GL_DISPLAY_TILE '平铺
iCt = CInt(destPicture.ScaleWidth / dw_pic) + 1
jCt = CInt(destPicture.ScaleHeight / dh_pic) + 1
For i = 1 To iCt
For j = 1 To jCt
'平铺
destPicture.PaintPicture srcPicture.Picture, (i - 1) * dw_pic, (j - 1) * dh_pic, dw_pic, dh_pic, 0, 0, srcPicture.ScaleWidth, srcPicture.ScaleHeight
Next j
Next i
Case GL_DISPLAY_STRETCH '拉伸
destPicture.PaintPicture srcPicture.Picture, 0, 0, destPicture.ScaleWidth, destPicture.ScaleHeight, 0, 0, srcPicture.ScaleWidth, srcPicture.ScaleHeight
End Select
End Sub
'判断给定的关键字段是否已经存在了
Public Function IsKeyColumnExists(ByVal szSQL As String, adoCONN As ADODB.Connection, ByVal szMsg As String) As Boolean
Dim rs As ADODB.Recordset
On Error GoTo ErrHandler
Set rs = adoCONN.Execute(szSQL)
If Not rs.EOF Then rs.MoveLast
If Not rs.BOF Then rs.MoveFirst
If ToLong(rs("ct")) >= 1 Then
MsgBox szMsg, vbOKOnly + vbInformation, "提示"
IsKeyColumnExists = True
Else
IsKeyColumnExists = False
End If
Set rs = Nothing
Exit Function
ErrHandler:
Set rs = Nothing
IsKeyColumnExists = True
ErrMessageBox "IsKeyColumnExists()", "提示"
End Function
'计算图像的缩放系数
'如果srcPicutre的每一边都比destPicture小,则显示原来的大小
'如果其中有一边比destPicture的大,则按大边缩放
Public Function PictureScaleRatio(srcPicture As PictureBox, destPicture As PictureBox) As Double
Dim r1 As Double
Dim r2 As Double
r1 = srcPicture.ScaleHeight / destPicture.ScaleHeight
r2 = srcPicture.ScaleWidth / destPicture.ScaleWidth
'取最大值
If r1 < r2 Then
r1 = r2
End If
If r1 < 1 Then
PictureScaleRatio = 1
Else
PictureScaleRatio = r1
End If
End Function
'只接收数字
Public Function AcceptNumber(ByVal KeyAscii As Integer) As Integer
Select Case KeyAscii
Case vbKey0, vbKey1, vbKey2, vbKey3, vbKey4, vbKey5, vbKey6, vbKey7, vbKey8, vbKey9, vbKeyBack, vbKeyTab, vbKeyDelete
AcceptNumber = KeyAscii
Case Else
AcceptNumber = 0
End Select
End Function
'生成考卷
Public Sub GenTestPaper()
Dim rs As ADODB.Recordset
Dim BL0 As Long '选择题
Dim BL1 As Long '判断题
Dim tmlb As Long '题目类别
Dim tmlx As Long '题目类型
Dim tmbh As Long '题目编号
Dim sResult(1 To 100) As String '用于记录选出的试卷题目
Dim sSelection() As String '
Dim szSQL As String
Dim i As Long
Dim ct As Long
Dim th As Long '随机的题号
Dim j As Long
Dim lUB As Long '数组上限
On Error GoTo ErrHandler
Screen.MousePointer = 11
'10:读取选择题、判断题的比例设置
Set rs = gadoCONN.Execute("SELECT xzt_bl,pdt_bl FROM tbParam WHERE id=1")
If Not rs.EOF Then rs.MoveLast
If Not rs.BOF Then rs.MoveFirst
If rs.RecordCount >= 1 Then
BL0 = ToLong(rs("xzt_bl"))
BL1 = ToLong(rs("pdt_bl"))
Else
MsgBox "请先设置系统参数！", vbOKOnly + vbInformation
Set rs = Nothing
Exit Sub
End If
'20:将所有的选择题读出来放在数组中
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
Set rs = gadoCONN.Execute("SELECT * FROM tbTk WHERE tmlx_id=0")
If Not rs.EOF Then rs.MoveLast
If Not rs.BOF Then rs.MoveFirst
ct = rs.RecordCount
ReDim sSelection(1 To ct)
'将选择题的题目类型、题目编号存起来
For i = 1 To ct
sSelection(i) = CStr(ToLong(rs("tmlb_id"))) & "-0" & "-" & CStr(ToLong(rs("tmbh")))
rs.MoveNext
Next i
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
'30:根据随机数产生选择题
For i = 1 To BL0
'产生随机数
lUB = UBound(sSelection)
Randomize '初始化
th = Int(lUB * Rnd() + 1)
'将产生的题目放在sResult中
sResult(i) = sSelection(th)
'调整数组sSelection:将已经产生的去掉
If th < lUB Then
For j = th + 1 To lUB
sSelection(j - 1) = sSelection(j)
Next j
End If
ReDim Preserve sSelection(1 To lUB - 1)
Next i
'40:判断题
Set rs = gadoCONN.Execute("SELECT * FROM tbTk WHERE tmlx_id=1")
If Not rs.EOF Then rs.MoveLast
If Not rs.BOF Then rs.MoveFirst
ct = rs.RecordCount
ReDim sSelection(1 To ct)
For i = 1 To ct
sSelection(i) = CStr(ToLong(rs("tmlb_id"))) & "-1" & "-" & CStr(ToLong(rs("tmbh")))
rs.MoveNext
Next i
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
'50:根据随机数产生判断题
For i = BL0 + 1 To 100
'产生随机数
lUB = UBound(sSelection)
Randomize '初始化
th = Int(lUB * Rnd() + 1)
'将产生的题目放在sResult中
sResult(i) = sSelection(th)
'调整数组sSelection:将已经产生的去掉
If th < lUB Then
For j = th + 1 To lUB
sSelection(j - 1) = sSelection(j)
Next j
End If
ReDim Preserve sSelection(1 To lUB - 1)
Next i
'60:清空试卷库
gadoCONN.Execute "DELETE FROM tbSj"
For i = 1 To 100
'取得题目类别、题目类型、题目编号
GetParameters sResult(i), tmlb, tmlx, tmbh
'写入数据库中
szSQL = "INSERT INTO tbSj(sjbh,tmlb_id,tmlx_id,tmbh) VALUES(" & _
CStr(i) & "," & CStr(tmlb) & "," & CStr(tmlx) & "," & CStr(tmbh) & ")"
gadoCONN.Execute szSQL
Next i
Screen.MousePointer = 0
Exit Sub
ErrHandler:
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
Screen.MousePointer = 0
ErrMessageBox "生成试卷出错GenTestPaper()", "提示"
End Sub
'根据文件名获取题目类别，题目类型，题目编号
Private Sub GetParameters(ByVal sParam As String, lpTmlb As Long, lpTmlx As Long, lpTmbh As Long)
Dim L1 As Long
Dim L2 As Long
'分离各编号
L1 = InStr(1, sParam, "-", vbTextCompare)
L2 = InStrRev(sParam, "-", , vbTextCompare)
lpTmlb = CLng(Left(sParam, L1 - 1))
lpTmlx = CLng(Mid(sParam, L1 + 1, L2 - L1 - 1))
lpTmbh = CLng(Mid(sParam, L2 + 1, Len(sParam) - L2))
End Sub