modmain.bas

Visual basic 数据库编程技术与实例源码 源码

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 Const GS_DATABASE_PROVIDER As String = "Microsoft.Jet.OLEDB.3.51"
Global Const GS_DATABASE_FILENAME As String = "tk.mdb" '数据库名
Global Const GS_DATABASE_STRING As String = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=exam;Data Source=localhost" '数据库连接字符串
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=959007123683"
    '-----------------------------------------
    '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
'--------------------------------------------------------------------
'图片以居中、平铺、拉伸显示(可以用于预览)
'参数说明：