Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>
'ResMe Converted To A Property: Const FORMCAPTION = "ODBC Logon"
'ResMe Converted To A Property: Const BUTTON1 = "&OK"
'ResMe Converted To A Property: Const BUTTON2 = "&Cancel"
'ResMe Converted To A Property: Const BUTTON3 = "&Register"
'ResMe Converted To A Property: Const FRAME1 = "Connect Values:"
'ResMe Converted To A Property: Const Label1 = "&DSN:"
'ResMe Converted To A Property: Const Label2 = "&UID:"
'ResMe Converted To A Property: Const LABEL3 = "&Password:"
'ResMe Converted To A Property: Const LABEL4 = "Data&base:"
'ResMe Converted To A Property: Const LABEL5 = "Dri&ver:"
'ResMe Converted To A Property: Const LABEL6 = "&Server:"
'ResMe Converted To A Property: Const MSG1 = "Enter ODBC Connection Parameters"
'ResMe Converted To A Property: Const MSG2 = "Opening ODBC Database"
'ResMe Converted To A Property: Const MSG3 = "Enter Driver Name:"
'ResMe Converted To A Property: Const MSG4 = "Driver Name"
'ResMe Converted To A Property: Const MSG5 = "This Datasource has not been Registered, this will now be attempted for you!"
'ResMe Converted To A Property: Const MSG7 = "Invalid Parameter(s), Please try again!"
'ResMe Converted To A Property: Const MSG8 = "Query Timeout Could not be set, default will be used!"
'ResMe Converted To A Property: Const MSG9 = "Datasource Registration Succeeded, proceed with Open."
'ResMe Converted To A Property: Const MSG10 = "Please enter a DSN!"
'ResMe Converted To A Property: Const MSG11 = "Please select a Driver!"
'ResMe Converted To A Property: Const MSG12 = "You must Close First!"
'>>>>>>>>>>>>>>>>>>>>>>>>

Dim mbBeenLoaded As Integer
Public DBOpened As Boolean

Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal henv&, ByVal fDirection%, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN%, ByVal szDescription$, ByVal cbDescriptionMax%, pcbDescription%) As Integer
Private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
Const SQL_SUCCESS As Long = 0
Const SQL_FETCH_NEXT As Long = 1


Private Sub cboDSNList_Change()
  If Len(cboDSNList.Text) = 0 Or cboDSNList.Text = "(None)" Then
    txtServer.Enabled = True
    cboDrivers.Enabled = True
    lblLabels(4).Enabled = True
    lblLabels(5).Enabled = True
  Else
    txtServer.Enabled = False
    cboDrivers.Enabled = False
    lblLabels(4).Enabled = False
    lblLabels(5).Enabled = False
  End If
End Sub

Private Sub cmdCancel_Click()
  gbDBOpenFlag = False
  gsDBName = vbNullString
  DBOpened = False
  Me.Hide
End Sub

Private Sub cmdOK_Click()
  On Error GoTo cmdOK_ClickErr

  Dim sConnect As String
  Dim dbTemp As Database

  MsgBar MSG2, True

  If frmMDI.mnuPOpenOnStartup.Checked Then
    Me.Refresh
  End If
  
  Screen.MousePointer = vbHourglass
  
  If Len(cboDSNList.Text) > 0 Then
    sConnect = "ODBC;DSN=" & cboDSNList.Text & ";"
  Else
    sConnect = "ODBC;Driver={" & cboDrivers.Text & "};"
    sConnect = sConnect & "Server=" & txtServer.Text & ";"
  End If
  
  sConnect = sConnect & "UID=" & txtUID.Text & ";"
  sConnect = sConnect & "PWD=" & txtPWD.Text & ";"
  If Len(txtDatabase.Text) > 0 Then
    sConnect = sConnect & "Database=" & txtDatabase.Text & ";"
  End If
  
  Set dbTemp = gwsMainWS.OpenDatabase("", 0, 0, sConnect)
  
  If gbDBOpenFlag Then
    CloseCurrentDB
    If gbDBOpenFlag Then
      Beep
      MsgBox MSG12, 48
      Me.Hide
      Exit Sub
    End If
  End If

  'success
  DBOpened = True
  'save the values
  gsODBCDatasource = cboDSNList.Text
  gsDBName = gsODBCDatasource
  gsODBCDatabase = txtDatabase.Text
  gsODBCUserName = txtUID.Text
  gsODBCPassword = txtPWD.Text
  gsODBCDriver = cboDrivers.Text
  gsODBCServer = txtServer.Text
  gsDataType = gsSQLDB

  Set gdbCurrentDB = dbTemp
  GetODBCConnectParts gdbCurrentDB.Connect

  cboDSNList.Text = gsODBCDatasource
  txtDatabase.Text = gsODBCDatabase
  txtUID.Text = gsODBCUserName
  txtPWD.Text = gsODBCPassword

  frmMDI.Caption = "VisData:" & gsDBName & "." & gsODBCDatabase
  gdbCurrentDB.QueryTimeout = glQueryTimeout

  gbDBOpenFlag = True
  AddMRU

  Screen.MousePointer = vbDefault
  Me.Hide
   
  Exit Sub

cmdOK_ClickErr:
  Screen.MousePointer = vbDefault
  gbDBOpenFlag = False
  If Len(cboDSNList.Text) > 0 Then
    If InStr(1, Error, "ODBC--connection to '" & cboDSNList.Text & "' failed") > 0 Then
      Beep
      MsgBox MSG5, 48
      txtDatabase.Text = vbNullString
      txtUID.Text = vbNullString
      txtPWD.Text = vbNullString
      If RegisterDB((cboDSNList.Text)) Then
        MsgBox MSG9, 48
      End If
    ElseIf InStr(1, Error, "Login failed") > 0 Then
      Beep
      MsgBox MSG7, 48
    ElseIf InStr(1, Error, "QueryTimeout property") > 0 Then
      If glQueryTimeout <> 5 Then
        Beep
        MsgBox MSG8, 48
      End If
      Resume Next
    Else
      ShowError
    End If
  End If
  
  MsgBar MSG1, False
  If Err = 3059 Then
    Unload Me
  End If

End Sub

Private Sub cmdRegister_Click()
  On Error GoTo cmdRegister_ClickErr
  
  If Len(cboDSNList.Text) = 0 Then
    MsgBox MSG10, vbInformation, Me.Caption
    Exit Sub
  End If
  If Len(cboDrivers.Text) = 0 Then
    MsgBox MSG11, vbInformation, Me.Caption
    Exit Sub
  End If
  
  'try to register it
  DBEngine.RegisterDatabase cboDSNList.Text, cboDrivers.Text, False, vbNullString

  MsgBox MSG9, vbInformation
  
  Exit Sub
cmdRegister_ClickErr:
  ShowError
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyF1 And Shift = 0 Then
    DisplayTopic 2016138
  End If
End Sub

Private Sub Form_Load()
    'ResMe autogenerated line of code to call the initialization routine that was automatically generated.
    Call frmODBCLogon_Auto_Init
  Dim i As Integer

  Me.Caption = FORMCAPTION
  cmdOK.Caption = BUTTON1
  cmdCancel.Caption = BUTTON2
  cmdRegister.Caption = BUTTON3
  fraConnection.Caption = FRAME1
  lblLabels(0).Caption = Label1
  lblLabels(1).Caption = Label2
  lblLabels(2).Caption = LABEL3
  lblLabels(3).Caption = LABEL4
  lblLabels(4).Caption = LABEL5
  lblLabels(5).Caption = LABEL6
  GetDSNsAndDrivers

  MsgBar MSG1, False
  
  cboDSNList.Text = gsODBCDatasource
  txtDatabase.Text = gsODBCDatabase
  txtUID.Text = gsODBCUserName
  txtPWD.Text = gsODBCPassword
  If Len(gsODBCDriver) > 0 Then
    For i = 0 To cboDrivers.ListCount - 1
      If cboDrivers.List(i) = gsODBCDriver Then
        cboDrivers.ListIndex = i
        Exit For
      End If
    Next
  End If
  txtServer.Text = gsODBCServer

  mbBeenLoaded = True
End Sub

Private Sub cboDSNList_Click()
  cboDSNList_Change
End Sub

Sub GetDSNsAndDrivers()
  On Error Resume Next
  
  Dim i As Integer
  Dim sDSNItem As String * 1024
  Dim sDRVItem As String * 1024
  Dim sDSN As String
  Dim sDRV As String
  Dim iDSNLen As Integer
  Dim iDRVLen As Integer
  Dim lHenv As Long     'handle to the environment

  cboDSNList.AddItem "(None)"

  'get the DSNs
  If SQLAllocEnv(lHenv) <> -1 Then
    Do Until i <> SQL_SUCCESS
      sDSNItem = Space(1024)
      sDRVItem = Space(1024)
      i = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)
      sDSN = VBA.Left(sDSNItem, iDSNLen)
      sDRV = VBA.Left(sDRVItem, iDRVLen)
        
      If sDSN <> Space(iDSNLen) Then
        cboDSNList.AddItem sDSN
        cboDrivers.AddItem sDRV
      End If
    Loop
  End If
  'remove the dupes
  If cboDSNList.ListCount > 0 Then
    With cboDrivers
      If .ListCount > 1 Then
        i = 0
        While i < .ListCount
          If .List(i) = .List(i + 1) Then
            .RemoveItem (i)
          Else
            i = i + 1
          End If
        Wend
      End If
    End With
  End If
  cboDSNList.ListIndex = 0
  
End Sub

Private Sub Form_Unload(Cancel As Integer)
  MsgBar vbNullString, False
End Sub

Private Function RegisterDB(rsDatasource As String) As Integer
   On Error GoTo RDBErr

   Dim sDriver As String

   sDriver = InputBox(MSG3, MSG4, gsDEFAULT_DRIVER)
   If sDriver <> gsDEFAULT_DRIVER Then
     DBEngine.RegisterDatabase rsDatasource, sDriver, False, vbNullString
   Else
     DBEngine.RegisterDatabase rsDatasource, sDriver, True, vbNullString
   End If

   RegisterDB = True
   Exit Function

RDBErr:
   RegisterDB = False
   
End Function


'*********************************************************************************
'**          This Section Of Code Was Automatically Generated By ResMe          **
'**                                                                             **
'** String assignments to Constants have been converted to read-only properties **
'*********************************************************************************


'This was: Const FORMCAPTION = "ODBC Logon"
Property Get FORMCAPTION As String
    FORMCAPTION = "ODBC Logon"
End Property

'This was: Const BUTTON1 = "&OK"
Property Get BUTTON1 As String
    BUTTON1 = "&OK"
End Property

'This was: Const BUTTON2 = "&Cancel"
Property Get BUTTON2 As String
    BUTTON2 = "&Cancel"
End Property

'This was: Const BUTTON3 = "&Register"
Property Get BUTTON3 As String
    BUTTON3 = "&Register"
End Property

'This was: Const FRAME1 = "Connect Values:"
Property Get FRAME1 As String
    FRAME1 = "Connect Values:"
End Property

'This was: Const Label1 = "&DSN:"
Property Get Label1 As String
    Label1 = "&DSN:"
End Property

'This was: Const Label2 = "&UID:"
Property Get Label2 As String
    Label2 = "&UID:"
End Property

'This was: Const LABEL3 = "&Password:"
Property Get LABEL3 As String
    LABEL3 = "&Password:"
End Property

'This was: Const LABEL4 = "Data&base:"
Property Get LABEL4 As String
    LABEL4 = "Data&base:"
End Property

'This was: Const LABEL5 = "Dri&ver:"
Property Get LABEL5 As String
    LABEL5 = "Dri&ver:"
End Property

'This was: Const LABEL6 = "&Server:"
Property Get LABEL6 As String
    LABEL6 = "&Server:"
End Property

'This was: Const MSG1 = "Enter ODBC Connection Parameters"
Property Get MSG1 As String
    MSG1 = "Enter ODBC Connection Parameters"
End Property

'This was: Const MSG2 = "Opening ODBC Database"
Property Get MSG2 As String
    MSG2 = "Opening ODBC Database"
End Property

'This was: Const MSG3 = "Enter Driver Name:"
Property Get MSG3 As String
    MSG3 = "Enter Driver Name:"
End Property

'This was: Const MSG4 = "Driver Name"
Property Get MSG4 As String
    MSG4 = "Driver Name"
End Property

'This was: Const MSG5 = "This Datasource has not been Registered, this will now be attempted for you!"
Property Get MSG5 As String
    MSG5 = "This Datasource has not been Registered, this will now be attempted for you!"
End Property

'This was: Const MSG7 = "Invalid Parameter(s), Please try again!"
Property Get MSG7 As String
    MSG7 = "Invalid Parameter(s), Please try again!"
End Property

'This was: Const MSG8 = "Query Timeout Could not be set, default will be used!"
Property Get MSG8 As String
    MSG8 = "Query Timeout Could not be set, default will be used!"
End Property

'This was: Const MSG9 = "Datasource Registration Succeeded, proceed with Open."
Property Get MSG9 As String
    MSG9 = "Datasource Registration Succeeded, proceed with Open."
End Property

'This was: Const MSG10 = "Please enter a DSN!"
Property Get MSG10 As String
    MSG10 = "Please enter a DSN!"
End Property

'This was: Const MSG11 = "Please select a Driver!"
Property Get MSG11 As String
    MSG11 = "Please select a Driver!"
End Property

'This was: Const MSG12 = "You must Close First!"
Property Get MSG12 As String
    MSG12 = "You must Close First!"
End Property


Private Sub frmODBCLogon_Auto_Init()
'This routine initializes all User Interface control properties on frmODBCLogon.
'This section of code was automatically generated by the ResMe String Extraction Utility.
    Me.Caption = "ODBC Logon"
    cmdRegister.Caption = "&Register"
    cmdCancel.Caption = "Cancel"
    cmdOK.Caption = "&OK"
    fraConnection.Caption = "Connection Values"
    cboDSNList.Text = "È"
    lblLabels(0).Caption = "&DSN:"
    lblLabels(1).Caption = "&UID:"
    lblLabels(2).Caption = "&Password:"
    lblLabels(3).Caption = "Data&base:"
    lblLabels(4).Caption = "Dri&ver:"
    lblLabels(5).Caption = "&Server:"
End Sub