Liren Large Software Subsidy 10/10.iso/l/l406/4.ddi/OPENDB.FR_/OPENDB.bin

Visual Basic Form | 1992-10-21 | 9.2 KB | 294 lines

VERSION 2.00
Begin Form fOpenDB
   BorderStyle     =   3  'Fixed Double
   Caption         =   "Open DataBase"
   ControlBox      =   0   'False
   Height          =   2835
   Left            =   2475
   LinkTopic       =   "Form2"
   ScaleHeight     =   2384.694
   ScaleMode       =   0  'User
   ScaleWidth      =   4477.44
   Top             =   3015
   Width           =   4545
   Begin ComboBox cDBName
      Height          =   288
      Left            =   1560
      Sorted          =   -1  'True
      TabIndex        =   0
      Text            =   "Combo1"
      Top             =   120
      Width           =   2772
   End
   Begin TextBox cDataBase
      Height          =   288
      Left            =   1560
      TabIndex        =   1
      Top             =   480
      Width           =   2772
   End
   Begin CheckBox cReadOnlyFlag
      Caption         =   "Read Only  (not supported by all Drivers)"
      Height          =   252
      Left            =   360
      TabIndex        =   4
      Top             =   1560
      Width           =   3996
   End
   Begin TextBox cUserName
      Height          =   288
      Left            =   1560
      TabIndex        =   2
      Top             =   840
      Width           =   2772
   End
   Begin TextBox cPassword
      Height          =   288
      Left            =   1560
      PasswordChar    =   "*"
      TabIndex        =   3
      Top             =   1200
      Width           =   2772
   End
   Begin CommandButton OkayButton
      Caption         =   "&Open"
      Default         =   -1  'True
      Height          =   372
      Left            =   360
      TabIndex        =   5
      Top             =   1896
      Width           =   1572
   End
   Begin CommandButton CancelButton
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   372
      Left            =   2520
      TabIndex        =   6
      Top             =   1896
      Width           =   1572
   End
   Begin Label DataBaseLabel
      Caption         =   "DataBase:"
      Height          =   249
      Left            =   120
      TabIndex        =   10
      Top             =   474
      Width           =   1339
   End
   Begin Label DBNameLabel
      Caption         =   "Source/Server:"
      Height          =   249
      Left            =   120
      TabIndex        =   7
      Top             =   118
      Width           =   1460
   End
   Begin Label UserNameLabel
      Caption         =   "User ID:"
      Height          =   249
      Left            =   120
      TabIndex        =   8
      Top             =   842
      Width           =   1339
   End
   Begin Label PasswordLabel
      Caption         =   "Password:"
      Height          =   249
      Left            =   120
      TabIndex        =   9
      Top             =   1186
      Width           =   1339
   End
Option Explicit
'ODBC.DLL APIs
Declare Function SQLAllocEnv Lib "odbc.dll" (env As Long) As Integer
Declare Function SQLDataSources Lib "ODBC.DLL" (ByVal henv As Long, ByVal fdir As Integer, ByVal szDSN As String, ByVal cbDSNMAx As Integer, pcbDSN As Integer, ByVal szDesc As String, ByVal cbDescMax As Integer, pcbDesc As Integer) As Integer
Sub CancelButton_Click ()
  gfDBOpenFlag = False
  Unload Me
End Sub
Sub cDBName_Click ()
  Dim tmp As String
  Dim x As Integer
  cDatabase = ""
  cUserName = ""
  cPassword = ""
  'get the database name if there is one
  tmp = String$(255, 32)
  x = OSGetPrivateProfileString(cDBName, "database", "", tmp, Len(tmp), "ODBC.INI")
  cDatabase = Mid$(tmp, 1, x)
  'get the last user name is there is one
  tmp = String$(255, 32)
  x = OSGetPrivateProfileString(cDBName, "lastuser", "", tmp, Len(tmp), "ODBC.INI")
  cUserName = Mid$(tmp, 1, x)
  cPassword = ""
  If cUserName <> "" Then cPassword.SetFocus
End Sub
Sub cDBName_LostFocus ()
  Call cDBName_Click
End Sub
Sub Form_Load ()
  cDBName = gstDBName
  cDatabase = gstDatabase
  cUserName = gstUserName
  cPassword = gstPassword
  Left = (Screen.Width - Width) / 2
  GetDataSources cDBName
  MsgBar "Enter DataBase Parameters", False
End Sub
Sub Form_Unload (Cancel As Integer)
  MsgBar "", False
End Sub
'this routine fills a list box with all available
'ODBC data sources found in ODBC.INI
Sub GetDataSources (listctrl As Control)
  Dim DataSource As String, Description As String
  Dim DataSourceLen As Integer, DescriptionLen As Integer
  Dim retcode As Integer
  Dim henv As Long
  If SQLAllocEnv(henv) <> -1 Then
    DataSource = String$(32, 32)
    Description = String$(255, 32)
    'get the first one
    retcode = SQLDataSources(henv, 2, DataSource, Len(DataSource), DataSourceLen, Description, Len(Description), DescriptionLen)
    While retcode = 0 Or retcode = 1
      listctrl.AddItem Mid(DataSource, 1, DataSourceLen)
      DataSource = String$(32, 32)
      Description = String$(255, 32)
      'get all the others
      retcode = SQLDataSources(henv, 1, DataSource, Len(DataSource), DataSourceLen, Description, Len(Description), DescriptionLen)
    Wend
  End If
End Sub
Sub OkayButton_Click ()
   Dim Connect As String
   Dim x As Integer
   Dim st As String
   Dim i As Integer
   Dim s As String, t As String
   Dim dbq As String
   On Error GoTo OpenError
   MsgBar "Opening DataBase", True
   If VDMDI.PrefOpenOnStartup.Checked = True Then
     Me.Refresh
   End If
   SetHourGlass Me
   'check for blank server name and clear other parms
   If cDBName = "" Then
     cDatabase = ""
     cUserName = ""
     cPassword = ""
   End If
   'build connect string
   If cUserName <> "" Then
     Connect = "UID=" + cUserName + ";PWD=" + cPassword
   End If
   If cDatabase <> "" Then
     Connect = Connect + ";DATABASE=" + cDatabase
   End If
   If InStr(1, Connect, "APP") = 0 Then
     Connect = Connect + ";APP=Visual Data"
   End If
   'save the values
   gstDBName = cDBName
   gstDatabase = cDatabase
   gstUserName = cUserName
   gstPassword = cPassword
   Me.Hide
   Set gCurrentDB = OpenDatabase(gstDBName, False, cReadOnlyFlag, Connect)
   If gfDBOpenFlag = True Then
     CloseAllDynasets
   End If
   gfTransPending = False
   VDMDI.QueryButton.Visible = True
   VDMDI.BeginButton.Visible = True
   VDMDI.CommitButton.Visible = False
   VDMDI.RollBackButton.Visible = False
   'process the connect string just in case the
   'values came from the ODBC dialogs
   t = gCurrentDB.Connect
   i = 1
   While i <= Len(t) + 1
     If Mid(t, i, 1) = ";" Or i = Len(t) + 1 Then
       If s <> "" Then
         Select Case Mid(s, 1, InStr(1, s, "=") - 1)
           Case "DSN"
             gstDBName = Mid(s, InStr(1, s, "=") + 1, Len(s))
           Case "DATABASE"
             gstDatabase = Mid(s, InStr(1, s, "=") + 1, Len(s))
           Case "DBQ"
             gstDatabase = Mid(s, InStr(1, s, "=") + 1, Len(s))
           Case "UID"
             gstUserName = Mid(s, InStr(1, s, "=") + 1, Len(s))
           Case "PWD"
             gstPassword = Mid(s, InStr(1, s, "=") + 1, Len(s))
         End Select
       End If
       s = ""
     Else
       s = s + Mid(t, i, 1)
     End If
     i = i + 1
   Wend
   cDBName = gstDBName
   cDatabase = gstDatabase
   cUserName = gstUserName
   cPassword = gstPassword
   x = OSWritePrivateProfileString(gstDBName, "Database", gstDatabase, "ODBC.INI")
   x = OSWritePrivateProfileString(gstDBName, "LastUser", gstUserName, "ODBC.INI")
   fTables.Caption = gstDBName + "." + gstDatabase
   gCurrentDB.QueryTimeout = Val(VDMDI.cQueryTimeout)
   'success
   gfDBOpenFlag = True
   ResetMouse Me
   Unload Me
   GoTo OkayEnd
OpenError:
   ResetMouse Me
   gfDBOpenFlag = False
   If cDBName <> "" Then
     If InStr(1, Error$, "Data source not found") > 0 Then
       Beep
       MsgBox "This DataBase has not been Registered, this will now be attempted for you!", 48
       cDatabase = ""
       cUserName = ""
       cPassword = ""
       If RegisterDB((cDBName)) = True Then
         MsgBox "'" + cDBName + "' has been Registered, proceed with Open.", 48
       End If
     ElseIf InStr(1, Error$, "Login failed") > 0 Then
       Beep
       MsgBox "Invalid Parameter(s), Please try again!", 48
     ElseIf InStr(1, Error$, "QueryTimeout property") > 0 Then
       If Val(VDMDI.cQueryTimeout) <> 5 Then
         Beep
         MsgBox "Query Timeout Could not be set, default will be used!", 48
       End If
       Resume Next
     Else
       ShowError
     End If
   End If
   MsgBar "Enter DataBase Parameters", False
   Me.Show MODAL
   Resume OkayEnd
OkayEnd:
End Sub
Function RegisterDB (dbname As String) As Integer
   On Error GoTo RDBErr
   Dim driver As String
   driver = InputBox("Enter Driver Name from ODBCINST.INI File:", "Driver Name", DEFAULTDRIVER)
   If driver <> DEFAULTDRIVER Then
     RegisterDatabase cDBName, driver, False, ""
   Else
     RegisterDatabase cDBName, driver, True, ""
   End If
   RegisterDB = True
   GoTo RDBEnd
RDBErr:
   RegisterDB = False
   Resume RDBEnd
RDBEnd:
End Function