DBConnection.frm

VERSION 5.00
Begin VB.Form frmDBConnection 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "Database Connection Builder"
   ClientHeight    =   3630
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   4995
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3630
   ScaleWidth      =   4995
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.CheckBox chkAdvanced 
      Caption         =   "View Advanced Settings"
      Height          =   195
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   3105
   End
   Begin VB.Frame fraDetails 
      Height          =   2745
      Left            =   120
      TabIndex        =   1
      Top             =   330
      Width           =   4785
      Begin VB.OptionButton optUseSQLAuthentication 
         Caption         =   "Use SQL Authentication"
         Height          =   225
         Left            =   120
         TabIndex        =   8
         Top             =   1650
         Width           =   2505
      End
      Begin VB.OptionButton optUseTrustedConnection 
         Caption         =   "Use Trusted Connection"
         Height          =   225
         Left            =   120
         TabIndex        =   7
         Top             =   1350
         Width           =   2505
      End
      Begin VB.TextBox txtPWD 
         Height          =   315
         IMEMode         =   3  'DISABLE
         Left            =   1080
         PasswordChar    =   "*"
         TabIndex        =   12
         Top             =   2310
         Width           =   2535
      End
      Begin VB.TextBox txtUID 
         Height          =   315
         Left            =   1080
         TabIndex        =   10
         Top             =   1920
         Width           =   2535
      End
      Begin VB.TextBox txtDBName 
         Height          =   315
         Left            =   1080
         TabIndex        =   5
         Top             =   600
         Width           =   3585
      End
      Begin VB.ComboBox cboSQLServer 
         Height          =   315
         Left            =   1080
         Sorted          =   -1  'True
         TabIndex        =   3
         Top             =   210
         Width           =   3585
      End
      Begin VB.Label lblSecurity 
         AutoSize        =   -1  'True
         Caption         =   "Security:"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Left            =   120
         TabIndex        =   6
         Top             =   1080
         Width           =   765
      End
      Begin VB.Label lblPassword 
         AutoSize        =   -1  'True
         Caption         =   "Password"
         Height          =   195
         Left            =   120
         TabIndex        =   11
         Top             =   2370
         Width           =   690
      End
      Begin VB.Label lblUser 
         AutoSize        =   -1  'True
         Caption         =   "User"
         Height          =   195
         Left            =   120
         TabIndex        =   9
         Top             =   1980
         Width           =   330
      End
      Begin VB.Label lblServer 
         AutoSize        =   -1  'True
         Caption         =   "Server"
         Height          =   195
         Left            =   120
         TabIndex        =   2
         Top             =   270
         Width           =   465
      End
      Begin VB.Label lblDatabase 
         AutoSize        =   -1  'True
         Caption         =   "Database"
         Height          =   195
         Left            =   120
         TabIndex        =   4
         Top             =   660
         Width           =   690
      End
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "Cancel"
      Height          =   345
      Left            =   3660
      TabIndex        =   21
      Top             =   3180
      Width           =   1245
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   345
      Left            =   2370
      TabIndex        =   20
      Top             =   3180
      Width           =   1275
   End
   Begin VB.Frame fraAdvanced 
      Height          =   1305
      Left            =   120
      TabIndex        =   13
      Top             =   3090
      Width           =   7305
      Begin VB.ComboBox cboDriver 
         Height          =   315
         Left            =   4680
         TabIndex        =   17
         Top             =   180
         Width           =   2535
      End
      Begin VB.ComboBox cboMode 
         Height          =   315
         Left            =   1080
         Sorted          =   -1  'True
         Style           =   2  'Dropdown List
         TabIndex        =   15
         Top             =   180
         Width           =   1305
      End
      Begin VB.TextBox txtConnection 
         Height          =   315
         Left            =   90
         TabIndex        =   19
         Top             =   900
         Width           =   7125
      End
      Begin VB.Label lblDriver 
         AutoSize        =   -1  'True
         Caption         =   "Driver"
         Height          =   195
         Left            =   3840
         TabIndex        =   16
         Top             =   240
         Width           =   420
      End
      Begin VB.Label lblMode 
         AutoSize        =   -1  'True
         Caption         =   "Mode"
         Height          =   195
         Left            =   90
         TabIndex        =   14
         Top             =   240
         Width           =   405
      End
      Begin VB.Label lblConnection 
         AutoSize        =   -1  'True
         Caption         =   "Connection:"
         Height          =   195
         Left            =   90
         TabIndex        =   18
         Top             =   630
         Width           =   855
      End
   End
End
Attribute VB_Name = "frmDBConnection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public Enum ConnectionModeEnum
    connectODBC = 0
    connectOLEDB = 1
End Enum

Private Const SQL_HANDLE_DBC = 2

Private Declare Function SQLAllocEnv Lib "odbc32.dll" (phenv As Long) As Integer

Private Declare Function SQLAllocHandle Lib "odbc32.dll" (ByVal hType As Integer, ByVal hInput As Long, ByRef phOutput As Long) As Integer

Private Declare Function SQLBrowseConnect Lib "odbc32.dll" (ByVal hDbc As Long, ByVal szConnStrIn As String, ByVal cbConnStrIn As Integer, ByVal szConnStrOut As String, ByVal cbConnStrOutMax As Integer, pcbconnstrout As Integer) As Integer

Private Declare Function SQLDisconnect Lib "odbc32.dll" (ByVal hDbc As Long) As Integer

Private Declare Function SQLFreeConnect Lib "odbc32.dll" (ByVal hDbc As Long) As Integer

Private Declare Function SQLFreeEnv Lib "odbc32.dll" (ByVal hEnv As Long) As Integer

Private Sub BuildConnectionString()
    Dim sText As String
    
    If (Len(cboSQLServer.Text) > 0) And (Len(txtDBName.Text) > 0) Then
        If cboMode.ListIndex = 0 Then
            sText = "DRIVER={" & cboDriver.Text & "};SERVER=" & cboSQLServer.Text & ";DATABASE=" & txtDBName.Text
            
            If optUseTrustedConnection.Value Then
                sText = sText & ";Trusted_Connection=yes"
            Else
                If Len(txtUID.Text) > 0 Then
                    sText = sText & ";UID=" & txtUID.Text
                End If
                If Len(txtPWD.Text) > 0 Then
                    sText = sText & ";PWD=" & txtPWD.Text
                End If
            End If
        Else
            sText = "Provider=" & cboDriver.Text & ";Data Source=" & cboSQLServer.Text & ";Initial Catalog=" & txtDBName.Text
            
            If optUseTrustedConnection.Value Then
                sText = sText & ";Integrated Security=SSPI"
            Else
                If Len(txtUID.Text) > 0 Then
                    sText = sText & ";User Id=" & txtUID.Text
                End If
                If Len(txtPWD.Text) > 0 Then
                    sText = sText & ";Password=" & txtPWD.Text
                End If
            End If
        End If
        
        txtConnection.Text = sText
    End If
End Sub

Public Property Get ConnectionString() As String
    ConnectionString = txtConnection.Text
End Property

Public Sub CreateConnection(Optional Server As String, Optional UserID As String, Optional Password As String, Optional ConnectionMode As ConnectionModeEnum = connectOLEDB)
    cboSQLServer.Text = Server
    txtDBName.Text = vbNullString
    txtUID.Text = UserID
    txtPWD.Text = Password

    optUseTrustedConnection.Value = True
    
    If ConnectionMode = connectODBC Then
        cboMode.ListIndex = 0
    Else
        cboMode.ListIndex = 1
    End If
    
    txtConnection.Text = vbNullString
End Sub

Private Sub cboDriver_Click()
    BuildConnectionString
End Sub

Private Sub cboDriver_Validate(Cancel As Boolean)
    BuildConnectionString
End Sub

Private Sub cboMode_Click()
    If cboMode.ListIndex = 0 Then
        lblDriver.Caption = "Driver"
        
        With cboDriver
            .Clear
            .AddItem "SQL Server"
            .AddItem "SQL Native Client"
            .AddItem "SQL Server Native Client 10.0"
            
            .ListIndex = 0
        End With
    Else
        lblDriver.Caption = "Provider"
        
        With cboDriver
            .Clear
            .AddItem "SQLOLEDB"
            .AddItem "SQLNCLI"
            .AddItem "SQLNCLI10"
            
            .ListIndex = 0
        End With
    End If
    
    BuildConnectionString
End Sub

Private Sub cboSQLServer_Click()
    BuildConnectionString
End Sub

Private Sub cboSQLServer_DropDown()
    Dim lCount As Long
    Dim sText As String
    Dim sValues() As String
    
    If cboSQLServer.ListCount = 0 Then
        Screen.MousePointer = vbHourglass
        
        sText = GetSQLServers("SQL Native Client")
        If Len(sText) = 0 Then
            sText = GetSQLServers()
        End If
        
        sValues() = Split(sText, ",")
        For lCount = LBound(sValues) To UBound(sValues)
            cboSQLServer.AddItem sValues(lCount)
        Next lCount
        
        Screen.MousePointer = vbDefault
    End If
End Sub

Private Sub cboSQLServer_Validate(Cancel As Boolean)
    BuildConnectionString
End Sub

Private Sub chkAdvanced_Click()
    SetView
End Sub

Private Sub cmdCancel_Click()
    Me.Tag = "0"
    Me.Hide
End Sub

Private Sub cmdOK_Click()
    If Len(txtConnection.Text) = 0 Then
        MsgBox "The Connection details are incomplete.", vbCritical
        
        If chkAdvanced.Value Then
            txtConnection.SetFocus
        End If
        Exit Sub
    End If

    Me.Tag = "1"
    Me.Hide
End Sub

Public Function Database() As String
    Database = txtDBName.Text
End Function

Private Sub Form_Activate()
    If Len(cboSQLServer.Text) > 0 And Len(txtDBName.Text) = 0 Then
        txtDBName.SetFocus
    Else
        cboSQLServer.SetFocus
    End If
End Sub

Private Sub Form_Load()
    With cboMode
        .AddItem "ODBC"
        .AddItem "OLEDB"
        
        .ListIndex = 1
    End With
    
    optUseTrustedConnection.Value = True
    SetView
End Sub

Public Function GetSQLServers(Optional sDriver As String = "SQL Server") As String
    Dim retCode As Long
    Dim hDbc As Long
    Dim hEnv As Long
    Dim strCon As String
    Dim strOutCon As String
    Dim intConLenOut As Integer
    
    strCon = "DRIVER={" & sDriver & "};"
    strOutCon = Space(1000)
    
    retCode = SQLAllocEnv(hEnv)
    retCode = SQLAllocHandle(SQL_HANDLE_DBC, ByVal hEnv, hDbc)
    retCode = SQLBrowseConnect(ByVal hDbc, strCon, Len(strCon), strOutCon, Len(strOutCon) + 2, intConLenOut)
    
    strOutCon = Left(strOutCon, intConLenOut)
    
    strOutCon = Mid(strOutCon, InStr(1, strOutCon, "Server={") + 8, (InStr(1, strOutCon, "}") - (InStr(1, strOutCon, "Server={") + 8)))
    
    GetSQLServers = strOutCon
    
    retCode = SQLDisconnect(hDbc)
    retCode = SQLFreeConnect(hDbc)
    retCode = SQLFreeEnv(hEnv)
End Function

Public Property Let ConnectionString(ByVal NewValue As String)
    With cboMode
        If InStr(1, NewValue, "DRIVER", vbTextCompare) > 0 Then
            cboMode.ListIndex = 0
        Else
            cboMode.ListIndex = 1
        End If
    End With
    
    cboSQLServer.Text = vbNullString
    txtDBName.Text = vbNullString
    txtUID.Text = vbNullString
    txtPWD.Text = vbNullString
    
    txtConnection.Text = NewValue
    
    ParseString NewValue
End Property

Private Sub optUseSQLAuthentication_Click()
    BuildConnectionString
    
    SetMode
End Sub

Private Sub optUseTrustedConnection_Click()
    BuildConnectionString
    
    SetMode
End Sub

Private Sub ParseString(sConnection As String)
    Dim nCount As Integer
    Dim nPos As Integer
    Dim bTrusted As Boolean
    Dim sData() As String
    
    sData() = Split(sConnection, ";")
    
    For nCount = LBound(sData) To UBound(sData)
        nPos = InStr(sData(nCount), "=")
        If nPos > 0 Then
            Select Case UCase$(Left$(sData(nCount), nPos - 1))
                Case "DSN"
                    txtConnection.Text = Mid$(sData(nCount), nPos + 1)
                Case "SERVER", "DATA SOURCE"
                    cboSQLServer.Text = Mid$(sData(nCount), nPos + 1)
                Case "DATABASE", "INITIAL CATALOG"
                    txtDBName.Text = Mid$(sData(nCount), nPos + 1)
                Case "UID", "USER ID"
                    txtUID.Text = Mid$(sData(nCount), nPos + 1)
                Case "PWD", "PASSWORD"
                    txtPWD.Text = Mid$(sData(nCount), nPos + 1)
                    
                Case "TRUSTED_CONNECTION", "INTEGRATED SECURITY"
                    Select Case LCase$(Mid$(sData(nCount), nPos + 1))
                        Case "yes", "sspi"
                            bTrusted = True
                    End Select
                
            End Select
        End If
    Next nCount

    If bTrusted Then
        optUseTrustedConnection.Value = True
    Else
        optUseSQLAuthentication.Value = True
    End If
End Sub

Public Function Password() As String
    Password = txtPWD.Text
End Function

Public Function Server() As String
    Server = cboSQLServer.Text
End Function

Private Sub SetMode()
    lblUser.Enabled = optUseSQLAuthentication.Value
    txtUID.Enabled = optUseSQLAuthentication.Value
    
    lblPassword.Enabled = optUseSQLAuthentication.Value
    txtPWD.Enabled = optUseSQLAuthentication.Value
End Sub

Private Sub SetView()
    Dim dTop As Single

    If chkAdvanced.Value = vbChecked Then
        fraAdvanced.Visible = True
        fraDetails.Width = fraAdvanced.Width
        
        dTop = fraAdvanced.Top + fraAdvanced.Height + 105
    Else
        fraAdvanced.Visible = False
        fraDetails.Width = 4785
        
        dTop = fraDetails.Top + fraDetails.Height + 105
    End If
    
    Me.Height = dTop + 810
    Me.Width = fraDetails.Width + 300
    
    cmdOK.Left = Me.Width - 2715
    cmdOK.Top = dTop
    
    cmdCancel.Left = Me.Width - 1425
    cmdCancel.Top = dTop
End Sub

Private Sub txtConnection_Validate(Cancel As Boolean)
    ParseString txtConnection.Text
End Sub


Private Sub txtDBName_Validate(Cancel As Boolean)
    BuildConnectionString
End Sub

Private Sub txtPWD_Validate(Cancel As Boolean)
    BuildConnectionString
End Sub

Private Sub txtUID_Validate(Cancel As Boolean)
    BuildConnectionString
End Sub

Public Function User() As String
    User = txtUID.Text
End Function