modstartup.bas

排队分诊管理系统源代码！该代码使用VB6开发环境

Attribute VB_Name = "modStartup"
Option Explicit

Dim m_tagErrInfo                As TYPE_ERRORINFO      ' 错误信息

'窗口托盘处理

Type NOTIFYICONDATA '定义结构NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

'以下为 Shell_NotifyIcon将用到的常量
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const NIM_MODIFY = &H1
        
Public procOld      As Long                 '保持原来的系统菜单处理函数的句柄
Public trayflag     As Boolean              '定义托盘图标是否在桌面上
Global lpPrevWndProc As Long
Global gHW As Long
                    
'以下为窗口常用消息
Public Const SC_SIZE = &HF000&
Public Const SC_MOVE = &HF010&
Public Const SC_MINIMIZE = &HF020&
Public Const SC_MAXIMIZE = &HF030&
Public Const SC_NEXTWINDOW = &HF040&
Public Const SC_PREVWINDOW = &HF050&
Public Const SC_CLOSE = &HF060&
Public Const SC_VSCROLL = &HF070&
Public Const SC_HSCROLL = &HF080&
Public Const SC_MOUSEMENU = &HF090&
Public Const SC_KEYMENU = &HF100&
Public Const SC_ARRANGE = &HF110&
Public Const SC_RESTORE = &HF120&
Public Const SC_TASKLIST = &HF130&
Public Const SC_SCREENSAVE = &HF140&
Public Const SC_HOTKEY = &HF150&

Public Const WM_SYSCOMMAND = &H112
Public Const WM_USER = &H400
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_SIZING = &H124

Public Const GWL_WNDPROC = (-4)
Private Const GWL_STYLE = (-16)

'Shell_NotifyIcon的函数声明
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
            (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
                    
'处理消息将用到的结构、常量、API声明
Type POINTAPI
    x As Long
    y As Long
End Type

Type Msg
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const SWP_NOMOVE = &H2
Public Const SWP_DRAWFRAME = &H20
Public Const WS_THICKFRAME = &H40000
Public Const WS_DLGFRAME = &H400000
Public Const WS_POPUP = &H80000000
Public Const WS_CAPTION = &HC00000
Public Const WS_SYSMENU = &H80000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_MINIMIZE = &H20000000
Public Const WS_MAXIMIZE = &H1000000

Public 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 Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
            (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
            (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) 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 HWND_TOPMOST& = -1

Public 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
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias _
            "WritePrivateProfileStringA" (ByVal lpApplicationName _
            As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
            ByVal lpFileName As String) 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

Private Sub main()
    On Error GoTo ERROR_EXIT
    Dim strUserDatabase$, strUserDatasource$
    Dim sNextFile As String, sPort As String
    Dim r As clsRegistry, Subkey As String, sINIFile As String
    Dim strLogFile As String, dFileLen As Double
        
    bolDBStatus = False
    
    Set r = New clsRegistry
    
    Subkey = "SOFTWARE\Shanghai YiXing Tech. Ltd. Co. \CyQueue\1.21\Server"
    sNextFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Path")
    sNextFile = RemoveNullChar(sNextFile)
    If sNextFile = "" Then
        sINIFile = App.Path & "\CyQueue.INI"
        SetErrorLogFile App.Path
    Else
        AddDirSep sNextFile
        sINIFile = sNextFile & "CyQueue.INI"
        
        strLogFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Logfile")
        dFileLen = CDbl(r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Logsize"))
        If strLogFile = "" Then
            SetErrorLogFile sNextFile
        Else
            SetErrorLogFile sNextFile, strLogFile, dFileLen / 1024
        End If
    End If

    strUserDatabase = sGetINI(sINIFile, "Settings", "DBName", "?")
    strUserDatasource = sGetINI(sINIFile, "Settings", "DBSource", "?")
    sPort = sGetINI(sINIFile, "Settings", "ServerPort", "0")
    
    If strUserDatabase = "?" Or strUserDatasource = "?" Then
        frmSet.Show vbModal
        Exit Sub
    End If
    
    If Not IsNumeric(sPort) Then
        default_server_port = 6000                          '缺省端口
    Else
        default_server_port = CLng(sPort)
        If default_server_port < 1 Or default_server_port > 65535 Then
            default_server_port = 0
        End If
    End If
    
    '保存数据库连接信息
    dbDataConnectSet strUserDatabase, strUserDatasource
    If Not Init_DB_Connect() Then GoTo ERROR_EXIT
    
    '初始化数据库信息完成
    bolDBStatus = True
    
    frmServer.Show
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "Main"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "主窗体启动函数。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    bolDBStatus = False
End Sub

'以下过程为消息循环处理
Public Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    
    If hw = frmServer.hWnd And uMsg = WM_USER + 100 Then    '检测到鼠标点动托盘图标
        Select Case lParam
            Case WM_RBUTTONDOWN                             '鼠标右键按下
                frmServer.PopupMenu frmServer.mnuMainmenu   '弹出菜单
            Case WM_LBUTTONDBLCLK                           '鼠标左键双击
                frmServer.Show                              '显示窗口
            Case Else
        End Select
    Else                                                    '调用缺省窗口指针
        WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
    End If
End Function

'将程序勾入消息环中
Public Sub Hook()
    On Error Resume Next
    
    '利用AddressOf取得消息处理函数WindowProc的指针，并将其传给SetWindowLong
    'lpPrevWndProc用来存储原窗口的指针
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub
    
Public Sub UnHook()
    On Error Resume Next
    
    '将程序从消息环退出。用原窗口的指针替换WindowProc函数的指针，即关闭子类、退出消息循环
    Dim temp As Long
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub

'以下为窗口系统消息相应函数，用于处理将 frmServer 窗口最小化
Public Function SysMenuProc(ByVal hWnd As Long, ByVal iMsg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    Dim bStatus As Boolean
        
    bStatus = False
    ' Ignore everything but system commands
    If iMsg = WM_SYSCOMMAND Then
        ' Check for one special menu item
        Select Case wParam
            Case SC_CLOSE
                bStatus = True
            Case Else
                bStatus = False
        End Select
    End If
    
    If bStatus = False Then
        ' Let old window procedure handle other messages
        SysMenuProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)
    Else
        frmServer.Hide
        SysMenuProc = 0
    End If
End Function

Public Sub ControlWindows(Optional ByVal SetTrue As Boolean = False)
    On Error Resume Next
    Dim dwStyle As Long
    
    dwStyle = GetWindowLong(frmServer.hWnd, GWL_STYLE)
    If SetTrue = False Then
        dwStyle = dwStyle Or WS_MINIMIZEBOX
    Else
        dwStyle = dwStyle - WS_MINIMIZEBOX
    End If
    dwStyle = SetWindowLong(frmServer.hWnd, GWL_STYLE, dwStyle)
    SetWindowPos frmServer.hWnd, 0, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''---------- Tool Function ----------''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'**********************************
' 去掉字符中的空字符及以后的字符
Public Function RemoveNullChar(ByVal str As String) As String
    Dim i As Integer
    Dim strTemp As String
    
    strTemp = str
    i = InStr(strTemp, vbNullChar)
    If i > 0 Then strTemp = Left(strTemp, i - 1)
    RemoveNullChar = strTemp
End Function

Public Function sGetINI(sINIFile As String, sSection As String, sKey _
                        As String, sDefault As String)
    On Error GoTo ERROR_EXIT
    Dim sTemp As String * 256
    Dim nLength As Integer
    
    sTemp = Space$(256)
    nLength = GetPrivateProfileString(sSection, sKey, sDefault, sTemp, _
            255, sINIFile)
    sGetINI = Left$(sTemp, nLength)
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "sGetINI"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "读INI文件失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    sGetINI = ""
End Function

Public Function sWriteINI(sINIFile As String, sSection As String, sKey _
                As String, sValue As String)
    On Error GoTo ERROR_EXIT
    Dim n As Integer
    Dim sTemp As String
    
    sTemp = sValue
     'Replace any CR/LF characters with spaces
    For n = 1 To Len(sValue)
        If Mid$(sValue, n, 1) = vbCr Or Mid$(sValue, n, 1) = vbLf _
        Then Mid$(sValue, n) = ""
    Next n
    
    n = WritePrivateProfileString(sSection, sKey, sTemp, sINIFile)
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "sWriteINI"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "写INI文件失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Function

'判断数组是否初始化
Public Function IsArrayInit(ByRef test() As user_type) As Boolean
    On Error GoTo ERROR_EXIT
    Dim i As Integer
    
    i = UBound(test)
    IsArrayInit = True
    Exit Function
ERROR_EXIT:
    IsArrayInit = False
End Function