frmserver.frm

朋友给的

         Top             =   1125
         Width           =   3500
      End
      Begin VB.TextBox txtOrPassword 
         Appearance      =   0  'Flat
         Height          =   315
         IMEMode         =   3  'DISABLE
         Left            =   1335
         PasswordChar    =   "*"
         TabIndex        =   21
         ToolTipText     =   "请输入3至8位已内的口令"
         Top             =   1545
         Width           =   3500
      End
      Begin VB.TextBox txtOrDatabase 
         Appearance      =   0  'Flat
         Height          =   315
         Left            =   1335
         TabIndex        =   20
         Top             =   720
         Width           =   3500
      End
      Begin VB.Label Label11 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "服务器名称："
         Height          =   180
         Left            =   180
         TabIndex        =   27
         Top             =   390
         Width           =   1080
      End
      Begin VB.Label Label10 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "管理员名称："
         Height          =   180
         Left            =   180
         TabIndex        =   26
         Top             =   1230
         Width           =   1080
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "口      令："
         Height          =   180
         Left            =   180
         TabIndex        =   25
         Top             =   1650
         Width           =   1080
      End
      Begin VB.Label Label8 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "数据库名称："
         Height          =   180
         Left            =   180
         TabIndex        =   24
         Top             =   795
         Width           =   1080
      End
   End
End
Attribute VB_Name = "frmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
                               
Private Sub CmdBack_Click()
    Unload Me
End Sub

'**************************
'由用户提供数据库初始化路径
'**************************
Private Sub cmdOk_Click()
    '判别当前修改的是哪个数据库
    '并修改注册表
    Dim KeyString As String
    Dim strsql     As String
    
On Error GoTo Err_Handle

    Set gCnn = New ADODB.Connection

    '注册表地址
    KeyString = gREG_APP_ROOT & "\" & gAPP_TYPE

    
    If OptSQLServer.Value = True Then
        gServer = txtServerName
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gServer", gServer
        '取数据库
        gDatabase = txtDbName
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gDatabase", gDatabase
        '取用户
        gUserName = txtUserName
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gUserName", gUserName
        '取密码
        gPassword = txtPassword
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gPassword", gPassword
        
        gDbtype = "0"
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gDbtype", gDbtype
        
        '连接书库
        strsql = "DRIVER ={SQL SERVER};" _
               & "UID=" & gUserName & ";" _
               & "PWD=" & Trim(gPassword) & ";" _
               & "DATABASE=" & gDatabase & ";" _
               & "SERVER=" & gServer
    
        gCnn.Provider = "SQLOLEDB"
        gCnn.CursorLocation = adUseClient
        gCnn.ConnectionString = strsql
        gCnn.CommandTimeout = 30
        gCnn.Open
        
        
    ElseIf OptAccess.Value = True Then
    
        '取数据库

        gAccessName = txtAccessDbname
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gAccessName", gAccessName

        '路径

        gAccessPath = txtAccessPath
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gAccessPath", gAccessPath
        '密码

        gAccessPasswd = txtAccessPasswd
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gAccessPasswd", gAccessPasswd
        gDbtype = "1"
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gDbtype", gDbtype
        
     '连接书库
        gCnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
            gAccessPath + gAccessName & ";Persist Security Info=False"
    
        gCnn.CommandTimeout = 10
        gCnn.CursorLocation = adUseClient
        gCnn.Open
        
    ElseIf OptOrcle.Value = True Then
        
        gOrcleServer = txtOrServerName
        gOrcleDatabase = txtOrDatabase
        gOrcleUserName = txtOrUid
        gOrclePassword = txtOrPassword
        
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gOrcleServer", gOrcleServer
        
        '取数据库
        
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gOrcleDatabase", gOrcleDatabase
        
        '取用户
        
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gOrcleUserName", gOrcleUserName
        
        '取密码
        
        gOrclePassword = GetKeyValue(HKEY_LOCAL_MACHINE, KeyString, "gOrclePassword", "")
    
        gDbtype = "2"
        SetKeyValue HKEY_LOCAL_MACHINE, KeyString, "gDbtype", gDbtype
        
        
     '连接书库
     
     
        
    End If
    
    Unload Me
    
    frmLogin.Show 1
    
'    Call Main
    Exit Sub
Err_Handle:
    MsgBox Err.Description, vbInformation, "系统提示"
    
End Sub

Private Sub cmdSelectDatabase_Click()
    With DLG
        .Filename = txtAccessDbname.Text
        .Filter = "*.*" & "|" & "*.*"
        .ShowOpen
        If .Filename <> "" Then
            If .Filename <> "" Then
                txtAccessPath.Text = GetFileNamePath(.Filename)
                txtAccessDbname.Text = GetFileName(.Filename)
            End If
        End If
    End With
End Sub


Private Sub Form_KeyPress(keyascii As Integer)
'    PressEnter KeyAscii
End Sub

Private Sub Form_Load()

On Error GoTo Err_Handle

If gDbtype = 0 Then
    OptSQLServer.Value = True
    fraAccess.Visible = False
    fraSQLServer.Visible = True
    FraOrcle.Visible = False
    txtServerName = gServer
    txtDbName = gDatabase
    txtUserName = gUserName
    txtPassword = gPassword
    
ElseIf gDbtype = 1 Then
    OptAccess.Value = True
    fraAccess.Visible = True
    fraSQLServer.Visible = False
    FraOrcle.Visible = False
    txtAccessPath = gAccessPath
    txtAccessDbname = gAccessName
    txtAccessPasswd = gAccessPasswd
ElseIf gDbtype = 2 Then
    OptOrcle.Value = True
    fraAccess.Visible = False
    fraSQLServer.Visible = False
    FraOrcle.Visible = True
    txtOrServerName = gOrcleServer
    txtOrDatabase = gOrcleDatabase
    txtOrUid = gOrcleUserName
    txtOrPassword = gOrclePassword
Else
End If

Exit Sub
Err_Handle:
  MsgBox Err.Description, vbInformation, "系统提示"
End Sub

Private Sub OptAccess_Click()
    fraAccess.Visible = True
    fraSQLServer.Visible = False
    FraOrcle.Visible = False
End Sub

Private Sub OptOrcle_Click()
    FraOrcle.Visible = True
    fraAccess.Visible = False
    fraSQLServer.Visible = False
End Sub

Private Sub OptSQLServer_Click()
    fraAccess.Visible = False
    fraSQLServer.Visible = True
    FraOrcle.Visible = False
End Sub