modglobaldbconnect.bas

1、以DLL形式提供医生工作站 2、 根据【检查项目】

Attribute VB_Name = "modGlobalDbConnect"
'----------------------------------------------------------------------------------------------------
'modGlobalDbConnect.bas
'作者：刘辉
'时间：2008-4-8
'说明：SQL Server2000数据库连接相关类
'----------------------------------------------------------------------------------------------------
Option Explicit



Const INI_FILE = "htpacs.ini"

Public myConn As New ADODB.Connection

'----------------------------------------------------------------------------------------------------
'变量定义

'数据库连接字符串
Private ConnectionString As String


Public HIS_ConnectionString As String


'默认数据库配置文件
Public Const DefDbConfName As String = "db.conf"

'----------------------------------------------------------------------------------------------------

Private Const DefDbServer As String = "127.0.0.1"   '默认数据库服务器名
'Public Const DefDbUserName As String = "pacs"      'SQL SERVER
Public Const DefDbUserName As String = "COMM"
Public Const DefDbUserPwd As String = "pacs"           '需加密
Public Const DefDbName As String = "HTPACS2"
'Public Const DefDbName As String = "oradb"

Private DbServerIp As String         '数据库服务器地址/名称
Private DbUserPwd As String         '数据库用户密码

'数据源类型及验证方式   方便数据库类型的移植
'Public Const DbType As String = "Provider=SQLOLEDB.1;Persist Security Info=False;"     'SQL Server

Public Const DbType As String = "Provider=OraOLEDB.Oracle.1;Persist Security Info=False;"     'ORACLE
'"Provider=OraOLEDB.Oracle.1;Persist Security Info=False;Server=192.168.0.13;"
'Database=HTPACS2;User ID=SYS;Password=change_on_install"
'----------------------------------------------------------------------------------------------------
'属性，获取连接字符串
Public Function GetConnectionString() As String
    GetConnectionString = ConnectionString
End Function
'属性，获取默认数据库配置文件名
Public Function GetDefDbConfName() As String
    GetDefDbConfName = DefDbConfName
End Function



'打开数据库连接配置文件，不存在则创建
Private Function CreateDbConfigFile(DbConfFileName As String) As Boolean
On Error GoTo ErrHandler
    
    If Dir(DbConfFileName, vbArchive) = "" Then
        Dim fs
        Dim hFile
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set hFile = fs.CreateTextFile(DbConfFileName, True)
        hFile.WriteLine (DefDbServer)
        hFile.WriteLine (DefDbUserPwd)
        hFile.Close
    End If
    
        CreateDbConfigFile = True
    Exit Function
    
'-------------------------------------------------------------------------------
ErrHandler:
        CreateDbConfigFile = False
        MsgBox Err.Description, vbCritical, "打开数据库配置文件失败!"
End Function


'初始化PACS连接----从注册表中读取加密后的字符
Public Function InitPacsConnRegEncrypt() As Boolean
    On Error GoTo ErrHandler
    
    Dim strPacsDataSource As String
    strPacsDataSource = Space(256)
    
    Dim strIniFilePath As String
    
    strIniFilePath = App.Path + "\" + INI_FILE
    
    Dim nRet As Long
    '获取
    nRet = GetPrivateProfileString("CONNECTION", "PACS_DATA_SOURCE", "", strPacsDataSource, 256, _
        strIniFilePath)
    strPacsDataSource = left(strPacsDataSource, nRet)
    
    If strPacsDataSource = "" Then
        InitPacsConnRegEncrypt = False
        Exit Function
    End If
    
    Dim strPacsUser As String
    strPacsUser = GetConnectionArg(regkey, PACS_REG_KEY_USER)
    If strPacsUser = "" Then
        InitPacsConnRegEncrypt = False
        Exit Function
    End If
    
    strPacsUser = PacsDecrypt(strPacsUser)
    If strPacsUser = "" Then
        InitPacsConnRegEncrypt = False
        Exit Function
    End If
    
    
    Dim strPacsPassword As String
    strPacsPassword = GetConnectionArg(regkey, PACS_REG_KEY_PASSWORD)
    If strPacsPassword = "" Then
        InitPacsConnRegEncrypt = False
        Exit Function
    End If
    
    strPacsPassword = PacsDecrypt(strPacsPassword)
    If strPacsPassword = "" Then
        InitPacsConnRegEncrypt = False
        Exit Function
    End If
    
    Dim pacsConn As New ADODB.Connection
    ConnectionString = DbType _
            + "Data Source=" + strPacsDataSource _
            + ";User ID=" + strPacsUser _
            + ";Password=" + strPacsPassword + ""
    pacsConn.Open ConnectionString
    
    If pacsConn.STATE = adStateOpen Then
        pacsConn.Close
        Set pacsConn = Nothing
    Else
        InitPacsConnRegEncrypt = False
        Exit Function
    
    End If
    
    
    InitPacsConnRegEncrypt = True
    Exit Function
ErrHandler:
    InitPacsConnRegEncrypt = False
End Function






'初始化PACS连接----从注册表中读取
Public Function InitPacsConnectionReg() As Boolean
    On Error GoTo ErrHandler
    
    Dim strPacsDataSource As String
    strPacsDataSource = Space(256)
    
    Dim strIniFilePath As String
    
    strIniFilePath = App.Path + "\" + INI_FILE
    
    Dim nRet As Long
    '获取
    nRet = GetPrivateProfileString("CONNECTION", "PACS_DATA_SOURCE", "", strPacsDataSource, 256, _
        strIniFilePath)
    strPacsDataSource = left(strPacsDataSource, nRet)
    
    If strPacsDataSource = "" Then
        InitPacsConnectionReg = False
        Exit Function
    End If
    
    
    Dim strPacsUser As String
    strPacsUser = GetConnectionArg(regkey, PACS_REG_KEY_USER)
    
    If strPacsUser = "" Then
        InitPacsConnectionReg = False
        Exit Function
    End If
    
    Dim strPacsPassword As String
    strPacsPassword = GetConnectionArg(regkey, PACS_REG_KEY_PASSWORD)
    
    If strPacsPassword = "" Then
        InitPacsConnectionReg = False
        Exit Function
    End If
    
    Dim pacsConn As New ADODB.Connection
    ConnectionString = DbType _
            + "Data Source=" + strPacsDataSource _
            + ";User ID=" + strPacsUser _
            + ";Password=" + strPacsPassword + ""
    
    pacsConn.Open ConnectionString
    
    If pacsConn.STATE = adStateOpen Then
        pacsConn.Close
        Set pacsConn = Nothing
    Else
        InitPacsConnectionReg = False
        Exit Function
    
    End If
    
    
    InitPacsConnectionReg = True
    Exit Function
ErrHandler:
    InitPacsConnectionReg = False
End Function



'初始化HIS连接
Public Function InitHisConnection() As Boolean
    On Error GoTo ErrHandler
    Dim hisConn As New ADODB.Connection
    Dim strHisDataSource As String
    strHisDataSource = Space(256)
    
    Dim strIniFilePath As String
    
    strIniFilePath = App.Path + "\" + INI_FILE
    
    Dim nRet As Long
    nRet = GetPrivateProfileString("CONNECTION", "HIS_DATA_SOURCE", "", strHisDataSource, 256, _
        strIniFilePath)
    strHisDataSource = left(strHisDataSource, nRet)
    
    If strHisDataSource = "" Then
        InitHisConnection = False
        Exit Function
    End If
    
    Dim strHisDbUser As String
    strHisDbUser = Space(256)
    
    nRet = GetPrivateProfileString("CONNECTION", "HIS_DBUSER", "", strHisDbUser, 256, _
        strIniFilePath)
    strHisDbUser = left(strHisDbUser, nRet)
    
    
    If strHisDbUser = "" Then
        InitHisConnection = False
        Exit Function
    End If
    
    
    Dim strHisDbPassword As String
    strHisDbPassword = Space(256)
    nRet = GetPrivateProfileString("CONNECTION", "HIS_DBPASSWORD", "", strHisDbPassword, 256, _
        strIniFilePath)
    strHisDbPassword = left(strHisDbPassword, nRet)
    
    
    If strHisDbPassword = "" Then
        InitHisConnection = False
        Exit Function
    End If
    
    HIS_ConnectionString = DbType _
            + "Data Source=" + strHisDataSource _
            + ";User ID=" + strHisDbUser _
            + ";Password=" + strHisDbPassword + ""
    
    hisConn.Open HIS_ConnectionString
    
    If hisConn.STATE = adStateOpen Then
        hisConn.Close
        Set hisConn = Nothing
    Else
        InitHisConnection = False
        Exit Function
    
    End If
    
    
    
    InitHisConnection = True
    Exit Function
ErrHandler:
    InitHisConnection = False
    
End Function


'初始化PACS连接
Public Function InitPacsConnection() As Boolean
    On Error GoTo ErrHandler
    Dim pacsConn As New ADODB.Connection
    Dim strPacsDataSource As String
    strPacsDataSource = Space(256)
    
    Dim strIniFilePath As String
    
    strIniFilePath = App.Path + "\" + INI_FILE
    
    Dim nRet As Long
    '获取
    nRet = GetPrivateProfileString("CONNECTION", "PACS_DATA_SOURCE", "", strPacsDataSource, 256, _
        strIniFilePath)
    strPacsDataSource = left(strPacsDataSource, nRet)
    
    If strPacsDataSource = "" Then
        InitPacsConnection = False
        Exit Function
    End If
    
    Dim strPacsDbUser As String
    strPacsDbUser = Space(256)
    
    nRet = GetPrivateProfileString("CONNECTION", "PACS_DBUSER", "", strPacsDbUser, 256, _
        strIniFilePath)
    strPacsDbUser = left(strPacsDbUser, nRet)
    
    
    If strPacsDbUser = "" Then
        InitPacsConnection = False
        Exit Function
    End If
    
    
    Dim strPacsDbPassword As String
    strPacsDbPassword = Space(256)
    nRet = GetPrivateProfileString("CONNECTION", "PACS_DBPASSWORD", "", strPacsDbPassword, 256, _
        strIniFilePath)
    strPacsDbPassword = left(strPacsDbPassword, nRet)
    
    
    If strPacsDbPassword = "" Then
        InitPacsConnection = False
        Exit Function
    End If
    
    ConnectionString = DbType _
            + "Data Source=" + strPacsDataSource _
            + ";User ID=" + strPacsDbUser _
            + ";Password=" + strPacsDbPassword + ""
    
    pacsConn.Open ConnectionString
    
    If pacsConn.STATE = adStateOpen Then
        pacsConn.Close
        Set pacsConn = Nothing
    Else
        InitPacsConnection = False
        Exit Function
    
    End If
    
    
    
    InitPacsConnection = True
    Exit Function
ErrHandler:
    InitPacsConnection = False
    
End Function





'初始化数据库连接，成功返回TRUE，否则返回FALSE
Public Function InitializeConnection(DbConfFileName As String) As Boolean
On Error GoTo ErrHandler

    Dim bNeedModify As Boolean
    bNeedModify = False
    
    DbServerIp = ""
    DbUserPwd = ""
    
    If CreateDbConfigFile(DbConfFileName) Then
            
        Dim fs
        Dim hFile
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set hFile = fs.OpenTextFile(DbConfFileName, 1, True)
        
        Dim strTmp As String
        
        strTmp = hFile.ReadLine
        If Len(Trim(strTmp)) <= 0 Then
            DbServerIp = DefDbServer
            bNeedModify = True
        Else
            DbServerIp = strTmp
        End If
        
        strTmp = hFile.ReadLine
        If Len(Trim(strTmp)) <= 0 Then
            DbUserPwd = DefDbUserPwd
            bNeedModify = True
        Else
            DbUserPwd = strTmp
        End If
        
        hFile.Close
    
'---------------------------------------------------------------------------------------------------
        Dim myConn As New ADODB.Connection
        ConnectionString = DbType _
            + "Data Source=" + DbServerIp _
            + ";User ID=" + DefDbUserName _
            + ";Password=" + DbUserPwd + ""
            
            '            + "Server=" + DbServerIp _
            '+ ";Database=" + DefDbName _

       
        myConn.ConnectionString = ConnectionString
        myConn.Open
        
        If myConn.STATE = adStateOpen Then
            myConn.Close
            Set myConn = Nothing
            
            '保存设置
            If bNeedModify Then
                Set fs = CreateObject("Scripting.FileSystemObject")
                Set hFile = fs.CreateTextFile(DbConfFileName, True)
                hFile.WriteLine (DbServerIp)
                hFile.WriteLine (DbUserPwd)
                hFile.Close
            End If
  
        End If
'---------------------------------------------------------------------------------------------------
        
    End If
    
    InitializeConnection = True
    Exit Function
ErrHandler:
    'MsgBox Err.Description, vbExclamation, "数据库连接出错"
    ERROR_STRING = Err.Description
    Dim str As String
    str = Err.Description
    InitializeConnection = False
End Function