mdlsystem.bas

本系统可用于医院和专业体检中心的健康体检管理

Attribute VB_Name = "mdlSystem"
Option Explicit

Public Enum BUID
    BROWSER_W = 0
    UPDATE_W = 1
    INSERT_W = 2
    DELETE_W = 3
End Enum

'Purpose:   Get Database Parameter
Public Function GetDatabaseParameter(Optional ByVal strDatabase As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strServer As String
    Dim strUseWinnt As String
    Dim strUID As String
    Dim strPWD As String
    Dim clsEncrypt As New CEncrypt
    Dim strConnectionString As String
    Dim strTempDatabaseName As String
    
    '首先判断文件是否存在，如果不存在，自动修复该文件
    If Dir(gstrCurrPath & DSNINIFile) = "" Then
        RepairConfig gstrCurrPath & DSNINIFile
    End If
    
    '服务器信息
    strServer = GetINI(gstrCurrPath & DSNINIFile, "Database", "Server", "?")
    If strServer = "?" Then
        '如果服务器信息被删掉，则用缺省值进行修复
        strServer = "SERVER"
        WriteINI gstrCurrPath & DSNINIFile, "Database", "Server", strServer
    End If
    
    '数据库名
    DatabaseName = GetINI(gstrCurrPath & DSNINIFile, "Database", "Database", "?")
    If DatabaseName = "?" Then
        DatabaseName = "DHTJ"
        WriteINI gstrCurrPath & DSNINIFile, "Database", "Database", DatabaseName
    End If
    
    '验证方式
    strUseWinnt = GetINI(gstrCurrPath & DSNINIFile, "Database", "UseWinnt", "?")
    If (UCase(strUseWinnt) <> "TRUE") And (UCase(strUseWinnt) <> "FALSE") Then
        strUseWinnt = "True"
        WriteINI gstrCurrPath & DSNINIFile, "Database", "UseWinnt", strUseWinnt
    End If
    
    '是否连接master数据库
    If strDatabase <> "" Then
        strTempDatabaseName = strDatabase
    Else
        strTempDatabaseName = DatabaseName
    End If
    strConnectionString = "Provider=SQLOLEDB.1;Initial Catalog=" & strTempDatabaseName & ";Data Source=" & strServer
    
    If UCase(strUseWinnt) = "TRUE" Then
        '采取了windows混合验证
        strConnectionString = strConnectionString & ";Integrated Security=SSPI;Persist Security Info=False"
    Else
        '获取用户信息
        strUID = GetINI(gstrCurrPath & DSNINIFile, "Database", "UID", "?")
        If strUID = "?" Then
            strUID = "sa"
            WriteINI gstrCurrPath & DSNINIFile, "Database", "UID", strUID
        End If
        
        '获取密码信息
        strPWD = GetINI(gstrCurrPath & DSNINIFile, "Database", "PWD", "?")
        If strPWD = "?" Then
            strPWD = clsEncrypt.Encode("sa", PasswordDepth)
            WriteINI gstrCurrPath & DSNINIFile, "Database", "PWD", strPWD
        End If
        
        '采取指定用户名称和密码验证
        strConnectionString = strConnectionString & ";Persist Security Info=True;User ID=" & strUID _
                & ";Password=" & clsEncrypt.Decode(strPWD, PasswordDepth)
    End If
    If strDatabase = "" Then
        '非master数据库
        gstrConString = strConnectionString
    Else
        'master数据库
        GetDatabaseParameter = strConnectionString
    End If
    
    If strDatabase = "" Then
        '非master数据库的时候才对全局变量进行赋值
        g_strServerName = strServer
        g_strDatabase = DatabaseName
        g_strUseWinnt = strUseWinnt
        g_strUserID = strUID
        g_strPassword = clsEncrypt.Decode(strPWD, PasswordDepth)
    End If
    
    Call CheckSpy
    Set clsEncrypt = Nothing
    
    'SQLServer连接串
'    gstrConString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=DHTJ;Data Source=LZDX-WMY"
'    gstrConString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;User ID=sa;Initial Catalog=DHTJ;Data Source=127.0.0.1"
    'ACCESS连接串
 '   gstrConString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\bttj.mdb"
    
'**************************20040328加入  闻*****************************
'    '打开Lis的数据库连接
detectLis:
    If gLisInterface = True Then
    
'        gstrConStringLis = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=lisdb;Data Source=192.168.1.200"
        gstrConStringLis = GetINI(gstrCurrPath & DSNINIFile, "Interface", "ConnectSTring", "")
'        gstrConStringLis = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Password=321;Initial Catalog=lisdb;Data Source=127.0.0.1"
        Set GConLis = New ADODB.Connection
        GConLis.ConnectionString = gstrConStringLis
        GConLis.CursorLocation = adUseClient
        GConLis.Open
    End If
'**************************20040328加入完  闻*****************************
    
    Exit Function
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
    Exit Function
ErrConfig:
    MsgBox "配置文件遭到损坏，请联系系统管理员！", vbCritical, "提示"
End Function

'根据传入参数获取指定属性值
'如果找不到记录，则以默认值进行填充
Public Function GetSystemProperty(ByVal strRecordKey As String, _
        Optional ByVal strDefaultValue As String = "0") As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strValue As String
    
    strSQL = "select SYSTEMPROPERTY from SET_SYSTEM" _
            & " where SYSTEMNAME='" & strRecordKey & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.EOF Then
        '没有记录。写入一条默认记录
        strValue = strDefaultValue
        strSQL = "insert into SET_SYSTEM(SYSTEMNAME,SYSTEMPROPERTY)" _
                & " values('" & strRecordKey & "','" & strValue & "')"
        GCon.Execute strSQL
    Else
        strValue = rstemp("SYSTEMPROPERTY")
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    GetSystemProperty = strValue
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'设置系统参数
Public Function SetSystemProperty(ByVal strRecordKey As String, _
        ByVal strValue As String, _
        Optional ByVal enuOperation As OperationType = Modify) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '探测是否存在该记录
    strSQL = "select SYSTEMNAME from SET_SYSTEM" _
            & " where SYSTEMNAME='" & strRecordKey & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then
        '增加新记录
        strSQL = "insert into SET_SYSTEM(SYSTEMNAME,SYSTEMPROPERTY) values(" _
                & "'" & strRecordKey & "'" _
                & ",'" & strValue & "'" _
                & ")"
        GCon.Execute strSQL
    Else
        rstemp.Close
        
        If enuOperation = Modify Then
            '更新
            strSQL = "update SET_SYSTEM set" _
                    & " SYSTEMPROPERTY='" & strValue & "'" _
                    & " where SYSTEMNAME='" & strRecordKey & "'"
            GCon.Execute strSQL
        End If
    End If
    
    SetSystemProperty = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'更新数据库表
Public Function AlterTable(ByVal strTableName As String, ByVal strFieldName As String, _
        ByVal strFieldType As String, Optional ByVal strDefaultValue As Variant) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    '探测是否存在该字段
    strSQL = "select top 1 " & strFieldName & " from " & strTableName
    Set rstemp = New ADODB.Recordset
    '关闭错误跟踪
    On Error Resume Next
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Err.Number <> 0 Then
        Err.Clear
        '增加新字段
        strSQL = "ALTER TABLE " & strTableName _
                & " ADD " & strFieldName & " " & strFieldType
        GCon.Execute strSQL
        
        '是否需要设置默认值
        If CStr(strDefaultValue) <> "" Then
            strSQL = "update " & strTableName & " set" _
                    & " " & strFieldName & "=" & strDefaultValue
            GCon.Execute strSQL
        End If
    Else
        If Not rstemp.EOF Then rstemp.Close
    End If
End Function