modstartup.bas

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

Attribute VB_Name = "modStartup"
Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''
' 错误信息
Dim m_tagErrInfo As TYPE_ERRORINFO

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Dim m_strComputerName As String
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpbuffer As String, ByRef nSize As Long) As Long

Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000

Public Const GW_CHILD As Long = 5&
Public Const GW_HWNDNEXT As Long = 2&

Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
                "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
                "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function GetWindow& Lib "user32" (ByVal hwnd&, ByVal wCmd&)
Public Declare Function GetDesktopWindow& Lib "user32" ()
Public Declare Function GetWindowText& Lib "user32" Alias "GetWindowTextA" _
                                    (ByVal hwnd&, ByVal lpString$, ByVal cch&)
Public Declare Function ShowWindow& Lib "user32" (ByVal hwnd&, ByVal nCmdShow&)
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 SetForegroundWindow Lib "User32.lib" Alias "SetForegroundWindowA" (ByVal hAppWindow&) As Boolean

Public Sub Main()
    On Error GoTo ERROR_EXIT
    
    Const sBaseCaption As String = "排队系统管理中心"
    Const sBaseCaption1 As String = "mdiQueue"
    
    If App.PrevInstance = True Then
          
        Dim hAppWindow&, sTemp$
        hAppWindow = GetWindow(GetDesktopWindow(), GW_CHILD)
      
        Do
            sTemp = String$(180, False)
            Call GetWindowText(hAppWindow, sTemp, 179)
  
            If InStr(sTemp, sBaseCaption) Then
                ActivatePrevInstance (hAppWindow) '使以前的窗口活动
                Exit Do
            End If
        
            If InStr(sTemp, sBaseCaption1) Then
                ActivatePrevInstance (hAppWindow) '使以前的窗口活动
            Exit Do
            End If
  
        ' 获得下一个子窗体
            hAppWindow = GetWindow(hAppWindow, GW_HWNDNEXT)
        Loop
    Else
        '第一次运行时
        frmLogin.Show
    End If
    
    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
End Sub

Private Sub ActivatePrevInstance(ByVal hAppWindow&)

    Call ShowWindow(hAppWindow, 9) 'SW_RESTORE = 9 <WinUser.h>

    '使窗口活动
    Call SetForegroundWindow(hAppWindow)
  
End Sub


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 Sub dbDataConnectSet(UserName As String, UserPass As String, _
                    UserDBName As String, UserDBSource As String)
    g_MyUserDB.strUserName = UserName
    g_MyUserDB.strUserPassword = UserPass
    g_MyUserDB.strUserDatabase = UserDBName
    g_MyUserDB.strUserDatasource = UserDBSource
End Sub

Public Function TurnOnMSDE(ByVal sServer As String, ByVal sLogin As String, _
    ByVal sPassword As String) As Boolean
    Dim oSvr As SQLDMO.SQLServer
    Dim i As Single, b As Boolean
    
    b = False
    Set oSvr = New SQLDMO.SQLServer
    On Error GoTo StartError
    oSvr.LoginTimeout = 60
    oSvr.Start True, sServer, sLogin, sPassword
    oSvr.Disconnect
    Set oSvr = Nothing
    If b = False Then
        i = Timer + 5
        While Timer < i
        Wend
    End If
    TurnOnMSDE = True
    Exit Function
StartError:
    If Err.Number = -2147023840 Then
        oSvr.Connect sServer, sLogin, sPassword
        b = True
        Resume Next
    End If
    If Err.Number = -2147023836 Then
        MsgBox "无法启动SQL Server服务！", vbOKOnly + vbExclamation, "严重错误！"
    End If
    oSvr.Disconnect
    Set oSvr = Nothing
    TurnOnMSDE = False
End Function

Public Function OpenDB() As Boolean
    On Error GoTo ERROR_EXIT
    
    bolDBStatus = True
    TurnOnMSDE g_MyUserDB.strUserDatasource, g_MyUserDB.strUserName, g_MyUserDB.strUserPassword
    
    Set dbMyDB = New ADODB.Connection
    dbMyDB.ConnectionString = _
        "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=" + g_MyUserDB.strUserName + _
        ";Password=" + g_MyUserDB.strUserPassword + ";Initial Catalog=" + g_MyUserDB.strUserDatabase + _
        ";Data Source=" + g_MyUserDB.strUserDatasource
    dbMyDB.Open
    OpenDB = True
    Exit Function
    
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "OpenDB"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "数据库主程序打开失败!"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Close
    MsgBox "数据库主程序打开失败!"
    OpenDB = False
End Function

Public Function CloseDB() As Boolean
    On Error GoTo ERROR_EXIT
    
    dbMyDB.Close
    Set dbMyDB = Nothing
    bolDBStatus = False
    CloseDB = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "CloseDB"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "数据库主程序关闭失败!"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Close
    MsgBox "数据库主程序关闭失败，数据可能丢失!"
    CloseDB = False
    
End Function

Public Function MaskString(str As String) As String
    On Error GoTo ERROR_EXIT
    Dim strMask, strSearchChar, strArray() As String
    Dim i As Integer
    strMask = str
    strSearchChar = "'"
    i = 0
    i = InStr(1, strMask, strSearchChar, 1)
    If i <> 0 Then
        strArray() = Split(strMask, strSearchChar, -1, vbTextCompare)
        strMask = Join(strArray, vbTab)