modstartup.bas

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

Attribute VB_Name = "modStartup"
Option Explicit

Dim m_tagErrInfo                As TYPE_ERRORINFO       ' 错误信息

Public dbMyDB                   As ADODB.Connection
Public bolDBStatus              As Boolean              ' 是否连建数据库

'打印数据
Type Print_Set
    '打印页眉
    print_head          As String
    '打印页脚
    print_foot          As String
End Type

Public my_print_set As Print_Set

'时间管理设置
Type Time_Set
    '是否启动时间管理
    time_use            As Boolean
    '开始服务时间
    time_start          As String
    '结束服务时间
    time_end            As String
End Type

Public my_time_set      As Time_Set

'服务停止后打印设置
Type Service_Stop_Print
    '是否停止打印数据
    stop_service_set    As Boolean
    '停止后打印数据
    print_date          As String
End Type

Public my_service_stop_print    As Service_Stop_Print

'数据库登陆信息记录
Private Type TYPE_USERDB
    strUserDatabase As String
    strUserDatasource As String
End Type

Public g_MyUserDB               As TYPE_USERDB

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 Sub main()
    On Error GoTo ERROR_EXIT
    Dim strUserDatabase$, strUserDatasource$
    Dim sNextFile As String, Leng As Integer, i As Integer
    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
    
    Leng = CInt(sGetINI(sINIFile, "User", "Count", 0))
    If Leng = 0 Then GoTo ERROR_EXIT

    For i = 1 To Leng
        strUserDatabase = sGetINI(sINIFile, "Settings", "DBName" & i, "?")
        strUserDatasource = sGetINI(sINIFile, "Settings", "DBSource" & i, "?")
    Next i
    
    '保存数据库连接信息
    dbDataConnectSet strUserDatabase, strUserDatasource
    If Not Init_DB_Connect() Then GoTo ERROR_EXIT
    If Not Init_DB_Set() Then GoTo ERROR_EXIT
    
    '初始化数据库信息完成
    bolDBStatus = True
    
    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 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 Sub dbDataConnectSet(UserDBName As String, UserDBSource As String)
    g_MyUserDB.strUserDatabase = UserDBName
    g_MyUserDB.strUserDatasource = UserDBSource
End Sub

Public Function Init_DB_Connect() As Boolean
    On Error GoTo ERROR_EXIT
    
    Set dbMyDB = New ADODB.Connection
    TurnOnMSDE g_MyUserDB.strUserDatasource, "C73#09M73@03W73_11X75$06", "SIdaiGAI503_LOUrong"
        
    dbMyDB.ConnectionString = _
        "Provider=SQLOLEDB.1;Persist Security Info=False;User ID = C73#09M73@03W73_11X75$06; " + _
        "Password = SIdaiGAI503_LOUrong; Initial Catalog = " + g_MyUserDB.strUserDatabase + _
        ";Data Source=" + g_MyUserDB.strUserDatasource
    dbMyDB.Open
    
    Init_DB_Connect = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "Init_DB_Connect"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "排队系统数据库打开失败!"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Close
    MsgBox "排队系统数据库打开失败!", vbCritical + vbOKOnly, "系统错误"
    Init_DB_Connect = False
End Function

Public Function Init_DB_Set() As Boolean
    On Error GoTo ERROR_EXIT
    
    If Not Init_Time_Set() Then GoTo ERROR_EXIT
    If Not Init_Service_Stop_Print() Then GoTo ERROR_EXIT
    If Not Init_Print_Set() Then GoTo ERROR_EXIT
    
    Init_DB_Set = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "Init_DB_Set"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "排队系统数据库初始化数据失败!"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Close
    MsgBox "排队系统数据库初始化数据失败!", vbCritical + vbOKOnly, "系统错误"
    Init_DB_Set = False
End Function

'初始化时间管理设置
Private Function Init_Time_Set() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String
    
    '初始化时间设置
    my_time_set.time_use = False
    my_time_set.time_start = ""
    my_time_set.time_end = ""
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    strSQL = "SELECT * FROM VIEW_SET_Time WHERE time_set = 0"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount = 1 Then
        rs.MoveFirst
        my_time_set.time_use = True
        my_time_set.time_start = TimeValue(rs!start_time)
        my_time_set.time_end = TimeValue(rs!end_time)
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    strSQL = ""
    
    Init_Time_Set = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "Init_Time_Set"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    If rs.State = adStateOpen Then rs.Close
    Init_Time_Set = False
End Function

'初始化服务停止后打印设置
Private Function Init_Service_Stop_Print() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String
    
    '初始化时间设置
    my_service_stop_print.stop_service_set = False
    my_service_stop_print.print_date = ""
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    strSQL = "SELECT * FROM VIEW_SET_Print_Stop WHERE stop_print = 0"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount = 1 Then
        rs.MoveFirst
        my_service_stop_print.stop_service_set = True
        my_service_stop_print.print_date = Trim$(rs!pd_name)
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    strSQL = ""
    
    Init_Service_Stop_Print = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDBSet"
    m_tagErrInfo.strErrFunc = "Init_Service_Stop_Print"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    If rs.State = adStateOpen Then rs.Close
    Init_Service_Stop_Print = False
End Function


'初始化打印信息管理
Private Function Init_Print_Set() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String
    
    '初始化时间设置
    my_print_set.print_head = ""
    my_print_set.print_foot = "请客户至休息区等候，注意屏幕提示。"
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    strSQL = "SELECT TOP 1 * FROM SystemSet ORDER BY ss_id"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount = 1 Then
        rs.MoveFirst
        If Not IsNull(rs!print_head) Then
            my_print_set.print_head = rs!print_head
        End If
        If Not IsNull(rs!print_foot) Then
            my_print_set.print_foot = rs!print_foot
        End If
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    strSQL = ""
    
    Init_Print_Set = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "Init_Print_Set"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    If rs.State = adStateOpen Then rs.Close
    Init_Print_Set = False
End Function

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