frmdbset.frm

VB6.0编写的医院影像系统

      Begin VB.CommandButton cmdCancel 
         Caption         =   "取消 [ESC]"
         Height          =   390
         Left            =   4800
         TabIndex        =   1
         Tag             =   "取消"
         Top             =   0
         Width           =   1275
      End
   End
   Begin VB.Label Label7 
      Caption         =   "在这里设置程序要连接到的数据信息，可以选择的数据库为ACCESS和SQL SERVER数据库。"
      Height          =   615
      Left            =   1320
      TabIndex        =   23
      Top             =   240
      Width           =   4695
   End
   Begin VB.Image Image1 
      Height          =   480
      Left            =   360
      Picture         =   "frmDBSet.frx":0277
      Top             =   240
      Width           =   480
   End
   Begin VB.Label Label2 
      Caption         =   "详细信息"
      Height          =   255
      Left            =   360
      TabIndex        =   8
      Top             =   1920
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "数据库类型"
      Height          =   255
      Left            =   360
      TabIndex        =   6
      Top             =   1080
      Width           =   1095
   End
End
Attribute VB_Name = "frmDBSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public bCancel As Boolean       '是否取消
Public bChanged As Boolean      '是否有更改

Private Sub cmdACCESSDir_Click()
    
    '-----------------------------
    '设置ACCESS的数据库目录
    '-----------------------------
    
    Dim strDir As String
    strDir = BrowseFolder(Me.hwnd, "选择ACCESS数据库文件的存放目录:")
    If strDir <> vbNullString Then
        txtACCESSDBDir.Text = strDir
    End If

End Sub

Private Sub cmdApplicate_Click()
    
    '--------------------
    '保存设置
    '--------------------
    
    SaveChange
    
End Sub

Private Sub cmdCancel_Click()
    
    bCancel = True
    Unload Me
    
End Sub

Private Sub cmdDBTest_Click()
    
    '------------------------------------
    '测试连接
    '------------------------------------
    
    On Error GoTo ErrHandle
    
    Dim ConnTest As New ADODB.Connection
    Dim strConn As String
    Dim strTemp As String
    
    Screen.MousePointer = vbHourglass
    
    Select Case True
        Case optDBType(0).Value     'ACCESS数据库
            strConn = Replace(STR_ACCESS_US_BASE, "%ACCESS_DB_DIR%", TrimDir(txtACCESSDBDir.Text))
            ConnTest.Open EnPassWord(strConn)
            ConnTest.Close
            strConn = Replace(STR_ACCESS_USDATA_BASE, "%ACCESS_DB_DIR%", TrimDir(txtACCESSDBDir.Text))
            ConnTest.Open EnPassWord(strConn)
            ConnTest.Close
            
        Case optDBType(1).Value     'SQL Server
            strConn = MakeSQLConnectionString(txtMSSQLServerName, txtMSSQLUserName, txtMSSQLPassword, cboSQLDBName.Text)
            ConnTest.Open strConn
            ConnTest.Close
'            strConn = Replace(STR_MSSQL_US_BASE, "%MSSQL_SERVER_NAME%", txtMSSQLServerName.Text)
'            strConn = Replace(strConn, "%MSSQL_USERID%", txtMSSQLUserName.Text)
'            ConnTest.Open strConn
'            ConnTest.Close
'            strConn = Replace(STR_MSSQL_USDATA_BASE, "%MSSQL_SERVER_NAME%", txtMSSQLServerName.Text)
'            strConn = Replace(strConn, "%MSSQL_USERID%", txtMSSQLUserName.Text)
'            ConnTest.Open strConn
'            ConnTest.Close
'
        Case optDBType(0).Value     '缺省的ACCESS数据库
            strConn = Replace(STR_ACCESS_US_BASE, "%ACCESS_DB_DIR%", TrimDir(txtDefaultACCESSDBDir.Text))
            ConnTest.Open EnPassWord(strConn)
            ConnTest.Close
            strConn = Replace(STR_ACCESS_USDATA_BASE, "%ACCESS_DB_DIR%", TrimDir(txtDefaultACCESSDBDir.Text))
            ConnTest.Open EnPassWord(strConn)
            ConnTest.Close
            
    End Select
    
    '显示信息,释放对象
    Screen.MousePointer = vbNormal
    MsgBox "数据库连接成功!", vbInformation, "连接测试"
    Set ConnTest = Nothing
    Exit Sub
    
ErrHandle:
    Screen.MousePointer = vbNormal
    MsgBox "数据库连接失败!" & vbCrLf & vbCrLf & "错误代码: " & vbCrLf & Err.Description & vbCrLf & vbCrLf & "请重新检查连接的设置!", vbCritical, "连接测试"
    Set ConnTest = Nothing
    
End Sub

Private Sub cmdOK_Click()

    '--------------------
    '保存设置并退出
    '--------------------
    
    SaveChange
    
    bCancel = False
    Unload Me

End Sub

Private Sub cmdRefresh_Click()
    
    '--------------------------------
    '填充服务器的数据库列表
    '--------------------------------
    
    Dim connTemp As New ADODB.Connection
    Dim rsTemp As New ADODB.Recordset
    Dim strConn As String
    
    On Error GoTo ErrHandle:
    
    Screen.MousePointer = vbHourglass
    strConn = MakeSQLConnectionString(txtMSSQLServerName, txtMSSQLUserName, txtMSSQLPassword)
    connTemp.Open strConn
    rsTemp.Open "SELECT NAME FROM MASTER.DBO.SYSDATABASES", connTemp, adOpenStatic, adLockReadOnly
    
    With rsTemp
        cboSQLDBName.ComboItems.Clear
        Do While Not .EOF
            cboSQLDBName.ComboItems.Add , , rsTemp!Name
            .MoveNext
        Loop
    End With
    
    Screen.MousePointer = vbNormal
    
    '释放对象
    rsTemp.Close
    Set rsTemp = Nothing
    connTemp.Close
    Set connTemp = Nothing
    
    Exit Sub
    
ErrHandle:
    Screen.MousePointer = vbNormal
    
End Sub

Private Sub Form_Load()
    
    '----------------------------
    '从INI文件中读取当前的设置
    '----------------------------
    
    Set tabDBInfo.SelectedTab = tabDBInfo.Tabs(tabDBInfo.Tabs.Count)
    cmdDBTest.Visible = False
    
    IniUS.ReadOptionForm Me
    txtDefaultACCESSDBDir.Text = App.Path
    txtMSSQLPassword.Text = DeCrypt(IniUS.GetString("DataBase", "MSSQL_PASSWORD"))
    
    Select Case IniUS.GetString("DataBase", "DBType")
        Case "ACCESS"   'ACCESS库
            optDBType(0).Value = 1
        
        Case "MSSQL"    'SQL Server
            optDBType(1).Value = 1
            
        Case "DEFAULT"  '缺省
            optDBType(2).Value = 1
        
    End Select
            optDBType(0).Visible = False
            optDBType(2).Visible = False

End Sub

Private Sub optDBType_Click(Index As Integer)
    
    
    Dim i As Integer
    
    cmdDBTest.Visible = True
    
    '将正确的Tab显示
    Select Case Index
        Case 0
            tabDBInfo.SelectedTab = Index + 1
            
        Case 1
            tabDBInfo.SelectedTab = Index + 1
            
        Case 2
            tabDBInfo.SelectedTab = Index + 1
            
    End Select
    
End Sub

Private Sub SaveChange()

    '------------------------------
    '应用设置,保存到INI文件中
    '------------------------------
    
    Dim strConn As String
    Dim strUS As String
    Dim strData As String
    Dim strDBType As String
    
    Select Case True
        Case optDBType(0).Value     'ACCESS数据库
            strDBType = "ACCESS"
            strUS = Replace(STR_ACCESS_US_BASE, "%ACCESS_DB_DIR%", TrimDir(txtACCESSDBDir.Text))
            strData = Replace(STR_ACCESS_USDATA_BASE, "%ACCESS_DB_DIR%", TrimDir(txtACCESSDBDir.Text))
            
        Case optDBType(1).Value     'SQL Server
            strDBType = "MSSQL"
            strUS = Replace(STR_MSSQL_US_BASE, "%MSSQL_SERVER_NAME%", txtMSSQLServerName.Text)
            strUS = Replace(strUS, "%MSSQL_USERID%", txtMSSQLUserName.Text)
            strData = Replace(STR_MSSQL_USDATA_BASE, "%MSSQL_SERVER_NAME%", txtMSSQLServerName.Text)
            strData = Replace(strData, "%MSSQL_USERID%", txtMSSQLUserName.Text)
            
        Case optDBType(2).Value     '系统缺省的ACCESS数据库
            strDBType = "DEFAULT"
            strUS = Replace(STR_ACCESS_US_BASE, "%ACCESS_DB_DIR%", TrimDir(txtDefaultACCESSDBDir.Text))
            strData = Replace(STR_ACCESS_USDATA_BASE, "%ACCESS_DB_DIR%", TrimDir(txtDefaultACCESSDBDir.Text))
            
    End Select
    
'    If IniUS.GetString("DataBase", "DBType") = strDBType And IniUS.GetString("DataBase", "USConnection") = strUS And IniUS.GetString("DataBase", "DataConnection") = strData Then
'        '如果没有更改则退出
'        Exit Sub
'    End If
    
    IniUS.PutString "DataBase", "DBType", strDBType
    IniUS.PutString "DataBase", "USConnection", strUS
    IniUS.PutString "DataBase", "DataConnection", strData
    IniUS.PutString "DataBase", "MSSQL_PASSWORD", Crypt(txtMSSQLPassword.Text)
    bChanged = True

    IniUS.WriteOptionForm Me
    
End Sub