mdlsimpleconnection.bas

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

Attribute VB_Name = "mdlSimpleConnection"
Option Explicit

Public GCon As ADODB.Connection
Public GRISCon As ADODB.Connection
Public gstrConString As String
Public g_strRisConString As String
Public gstrCurrPath As String                           '含斜杠的应用程序路径
Public Const DSNINIFile = "Config\DSN\ODBC.INI"         '数据库INI文件
Public Const COMMUNICATION_STRING = "[e-mail]"
Public Const HEADER = "W"
Public DatabaseName As String                           '数据库名
Public RisDatabaseName As String
Public Const PasswordDepth = -15
Public Const CustomError = 555555
Public lngParentHWnd As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

'操作
Public Enum OperationType
    Add = 0
    Modify = 1
End Enum

Public Sub Main()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim strValue As String
    Dim strTitle As String
    
    Screen.MousePointer = vbArrowHourglass
    
    '实例是否已经启动
    If App.PrevInstance Then
        strTitle = App.Title
        App.Title = ""
        AppActivate strTitle
        End
    End If
    
    If Left(Command, InStr(1, Command, " ") - 1) <> COMMUNICATION_STRING Then
        MsgBox "该应用程序无法从外部调用！", vbExclamation, "警告"
        End
    End If
    '截取父窗口句柄
    lngParentHWnd = CLng(Val(Mid(Command, InStr(1, Command, " ") + 1)))
    
    '设置应用程序路径
    Call SetCurrPath
    
    '获取连接参数
    Call GetDatabaseParameter
    
    '连接数据库
    If ConnectDatabase(GCon) = False Then
        Screen.MousePointer = vbDefault
        End
    End If
    
    'RIS中间数据库
    strValue = GetINI(gstrCurrPath & DSNINIFile, "Interface", "RISInterfaceDatabase", "")
    If strValue = "" Then
        '用缺省值进行修复
        strValue = "DHTJ_ZJDATA"
        Call WriteINI(gstrCurrPath & DSNINIFile, "Interface", "RISInterfaceDatabase", strValue)
    End If
    g_strRisConString = GetDatabaseParameter(strValue)
    '连接RIS数据库
    Call ConnectDatabase(GRISCon, , g_strRisConString)
    
    '启动主窗体
    Screen.MousePointer = vbDefault
    frmRISTools.Show
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err, vbExclamation
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'连接数据库
'参数1：欲连接的对象
'参数2：游标类型。可选。默认为客户端游标
Public Function ConnectDatabase(ByRef con As ADODB.Connection, _
        Optional ByVal adCursorType As CursorLocationEnum = adUseClient, _
        Optional ByVal strConString As String) As Boolean
On Error GoTo ErrTrap
    Dim strMsg As String
    Dim strStatus
    Screen.MousePointer = vbArrowHourglass
    
    '检查连接对象是否存在
    If con Is Nothing Then
        Set con = New ADODB.Connection
    End If
    '初始化
    ConnectDatabase = False
    If strConString = "" Then
        con.ConnectionString = gstrConString
    Else
        con.ConnectionString = strConString
    End If
    con.CursorLocation = adCursorType
    con.Open
    
    ConnectDatabase = True  '成功连接数据库
    Screen.MousePointer = vbDefault
    Exit Function
ErrTrap:
    Screen.MousePointer = vbDefault
    MsgBox Err, vbExclamation
    
    strMsg = "无法连接数据库，请检查是否存在以下原因：" & vbCrLf _
                & vbCrLf & "*Microsoft SQL Server尚未运行" _
                & vbCrLf & "*ODBC配置文件被损坏" _
                & vbCrLf & "*ODBC连接被删除或数据源被移动" _
                & vbCrLf & "*数据库被人为损坏" _
                & vbCrLf & vbCrLf & "请联系系统管理员！"
    MsgBoxW Err, vbExclamation
End Function

'确保建立了数据库连接
Public Function CheckConnection(ByRef con As ADODB.Connection) As Boolean
On Error GoTo ErrMsg
    Dim Msg As String
    
    CheckConnection = False '假设连接未建立
    
    If Not (con Is Nothing) Then '说明开始时已连接上
        If con.State <> adStateOpen Then
            If ConnectDatabase(con) = False Then Exit Function
        End If
    
    Else '一开始时就未未连接上
        '再尝试一次
        If ConnectDatabase(con) = False Then
            Exit Function
        End If
    End If
    
    CheckConnection = True '连接已建立
    Exit Function
ErrMsg:
    '
End Function

'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:
    
'**************************20040328加入完  闻*****************************
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
    GoTo ExitLab
ErrConfig:
    MsgBox "配置文件遭到损坏，请联系系统管理员！", vbCritical, "提示"
ExitLab:
    '
End Function

'设置应用程序的当前路径：含斜杠“\”
Public Sub SetCurrPath()
On Error Resume Next
    If Right(App.Path, 1) <> "\" Then
        gstrCurrPath = App.Path & "\"
    Else
        gstrCurrPath = App.Path
    End If
End Sub

'错误提示
Public Sub MsgBoxW(ByRef errObject As errObject, Optional ByVal vbMsgStyle As VbMsgBoxStyle = vbInformation, _
        Optional ByVal strMsgTitle As String)
    If strMsgTitle = "" Then strMsgTitle = errObject.Source
    MsgBox "Error " & errObject.Number & " in " & errObject.Source & ":" & vbCrLf _
            & errObject.Description, vbMsgStyle, strMsgTitle
End Sub

'根据传入参数获取指定属性值
'如果找不到记录，则以默认值进行填充
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:
    MsgBoxW Err
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
    
    If enuOperation = Modify Then
        '更新
        strSQL = "update SET_SYSTEM set" _
                & " SYSTEMPROPERTY='" & strValue & "'" _
                & " where SYSTEMNAME='" & strRecordKey & "'"
        GCon.Execute strSQL
    Else
        '添加
        '探测是否存在该记录
        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
        End If
    End If
    
    SetSystemProperty = True
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    '
End Function

'选择组合框内容
Public Sub SelectComboxItem(ByRef cmbItem As ComboBox, ByVal strItem As String)
    Dim i As Integer
    Dim blnExist As Boolean
    
    With cmbItem
        For i = 0 To .ListCount - 1
            If .List(i) = strItem Then
                .ListIndex = i
                blnExist = True
                Exit For
            End If
        Next i
    End With
    
    If Not blnExist Then
        cmbItem.Text = strItem
    End If
End Sub