dlgserver.frm

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

VERSION 5.00
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form dlgServer 
   BackColor       =   &H80000018&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "数据库连接属性"
   ClientHeight    =   4545
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   5520
   Icon            =   "dlgServer.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4545
   ScaleWidth      =   5520
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1 
      BackColor       =   &H80000018&
      Caption         =   "服务器信息"
      Height          =   3525
      Left            =   180
      TabIndex        =   0
      Top             =   210
      Width           =   5145
      Begin VB.ComboBox cmbServer 
         Height          =   315
         Left            =   720
         TabIndex        =   5
         Top             =   990
         Width           =   3045
      End
      Begin VB.OptionButton optUseWinnt 
         BackColor       =   &H80000018&
         Caption         =   "使用Windows NT集成安全验证(&W)"
         Height          =   315
         Left            =   690
         TabIndex        =   4
         Top             =   1800
         Width           =   3075
      End
      Begin VB.OptionButton optUseUser 
         BackColor       =   &H80000018&
         Caption         =   "使用指定的用户名称和密码(&U)"
         Height          =   315
         Left            =   690
         TabIndex        =   3
         Top             =   2280
         Width           =   3015
      End
      Begin VB.TextBox txtUser 
         Height          =   285
         Left            =   1980
         TabIndex        =   2
         Top             =   2685
         Width           =   2505
      End
      Begin VB.TextBox txtPassword 
         Height          =   285
         IMEMode         =   3  'DISABLE
         Left            =   1980
         PasswordChar    =   "*"
         TabIndex        =   1
         Top             =   3045
         Width           =   2505
      End
      Begin XPControls.XPCommandButton cmdRefresh 
         Height          =   315
         Left            =   3870
         TabIndex        =   6
         Top             =   990
         Width           =   645
         _ExtentX        =   1138
         _ExtentY        =   556
         Caption         =   "刷新"
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackColor       =   &H80000018&
         Caption         =   "配置如下设置以连接到SQL Server数据库："
         Height          =   195
         Left            =   300
         TabIndex        =   11
         Top             =   300
         Width           =   3345
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         BackColor       =   &H80000018&
         Caption         =   "1. 选择或输入服务器名称(&E)："
         Height          =   195
         Left            =   420
         TabIndex        =   10
         Top             =   690
         Width           =   2355
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         BackColor       =   &H80000018&
         Caption         =   "2. 登录服务器的方式："
         Height          =   195
         Left            =   420
         TabIndex        =   9
         Top             =   1440
         Width           =   1800
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         BackColor       =   &H80000018&
         Caption         =   "用户名称："
         Height          =   195
         Left            =   1020
         TabIndex        =   8
         Top             =   2730
         Width           =   900
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         BackColor       =   &H80000018&
         Caption         =   "密码："
         Height          =   195
         Left            =   1020
         TabIndex        =   7
         Top             =   3090
         Width           =   540
      End
   End
   Begin XPControls.XPCommandButton cmdCancel 
      Height          =   375
      Left            =   3210
      TabIndex        =   12
      Top             =   3930
      Width           =   975
      _ExtentX        =   1720
      _ExtentY        =   661
      Caption         =   "取消(&C)"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdOK 
      Height          =   375
      Left            =   1620
      TabIndex        =   13
      Top             =   3930
      Width           =   975
      _ExtentX        =   1720
      _ExtentY        =   661
      Caption         =   "确定(&O)"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "dlgServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
Dim mblnOK As Boolean

'被调函数
Public Function Connection() As Boolean
    Me.Show vbModal
    Connection = mblnOK
End Function

Private Sub cmdCancel_Click()
    mblnOK = False
    Unload Me
End Sub

Private Sub cmdOK_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strServer As String
    Dim blnUseWinnt As Boolean
    Dim strUser As String
    Dim strPassword As String
    Dim con As ADODB.Connection
    Dim clsEncrypt As New CEncrypt
    
    Me.MousePointer = vbHourglass
    mblnOK = False
    
    '是否选择了服务器
    If cmbServer.Text = "" Then
        MsgBox "请输入或选择服务器名称！", vbInformation, "提示"
        cmbServer.SetFocus
        GoTo ExitLab
    End If
    strServer = cmbServer.Text
    
    strSQL = "Provider=SQLOLEDB.1;Initial Catalog=" & DatabaseName & ";Data Source=" & strServer
    
    '选择了哪一种验证方式
    If optUseWinnt.Value = True Then
        '采取了windows混合验证
        strSQL = strSQL & ";Integrated Security=SSPI;Persist Security Info=False"
    Else
        '采取指定用户名称和密码验证
        strSQL = strSQL & ";Persist Security Info=True;User ID=" & txtUser.Text _
                & ";Password=" & txtPassword.Text
    End If
    
    Set con = New ADODB.Connection
    con.ConnectionString = strSQL
    con.CursorLocation = adUseClient
    con.Open
    If Err.Number <> 0 Then
        MsgBox "无法连接指定的数据库！请确认是否有适当的权限、服务器正在运行，或者数据库“" _
                & DatabaseName & "”已成功附加！", vbCritical, "提示"
        GoTo ExitLab
        Err.Clear
    End If
    con.Close
    Set con = Nothing
    
    '如果成功，则把配置信息写入配置文件
    WriteINI gstrCurrPath & DSNINIFile, "Database", "Server", strServer
    If optUseWinnt.Value = True Then
        WriteINI gstrCurrPath & DSNINIFile, "Database", "UseWinnt", "True"
    Else
        WriteINI gstrCurrPath & DSNINIFile, "Database", "UseWinnt", "False"
        WriteINI gstrCurrPath & DSNINIFile, "Database", "UID", txtUser.Text
        WriteINI gstrCurrPath & DSNINIFile, "Database", "PWD", clsEncrypt.Encode(txtPassword.Text, PasswordDepth)
    End If
    
    Set clsEncrypt = Nothing
    
    mblnOK = True
    '连接成功
    Unload Me
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdRefresh_Click()
    GetLocalSQLServer cmbServer
End Sub

Private Sub Form_Load()
On Error Resume Next
    Dim strUseWinnt As String
    Dim clsEncrypt As New CEncrypt
    
    '服务器信息
    cmbServer.Text = GetINI(gstrCurrPath & DSNINIFile, "Database", "Server", "")
    
    '验证方式
    strUseWinnt = GetINI(gstrCurrPath & DSNINIFile, "Database", "UseWinnt", "?")
    If UCase(strUseWinnt) = "True" Then
        '混合验证
        optUseWinnt.Value = True
    Else
        optUseUser.Value = True
        
        txtUser.Text = GetINI(gstrCurrPath & DSNINIFile, "Database", "UID", "")
        txtPassword.Text = clsEncrypt.Decode(GetINI(gstrCurrPath & DSNINIFile, "Database", "PWD", "?"), PasswordDepth)
    End If
    
    Set clsEncrypt = Nothing
End Sub

Private Sub optUseWinnt_Click()
    txtUser.Enabled = False
    txtPassword.Enabled = False
    
    txtUser.BackColor = &H8000000F
    txtPassword.BackColor = &H8000000F
End Sub

Private Sub optUseUser_Click()
    txtUser.Enabled = True
    txtPassword.Enabled = True
    
    txtUser.BackColor = vbWhite
    txtPassword.BackColor = vbWhite
End Sub