home *** CD-ROM | disk | FTP | other *** search
VERSION 2.00 Begin Form fOpenDB BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Open DataBase" ClientHeight = 2160 ClientLeft = 2460 ClientTop = 3840 ClientWidth = 4395 ControlBox = 0 'False ForeColor = &H00C0C0C0& Height = 2565 Left = 2400 LinkTopic = "Form2" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 2119.728 ScaleMode = 0 'User ScaleWidth = 4447.084 Top = 3495 Width = 4515 Begin ComboBox cDBName BackColor = &H00FFFFFF& Height = 300 Left = 1680 Sorted = -1 'True TabIndex = 0 Tag = "OL" Top = 105 Width = 2655 End Begin TextBox cDataBase BackColor = &H00FFFFFF& Height = 285 Left = 1680 TabIndex = 1 Tag = "OL" Top = 465 Width = 2655 End Begin TextBox cUserName BackColor = &H00FFFFFF& Height = 285 Left = 1680 TabIndex = 2 Tag = "OL" Top = 825 Width = 2655 End Begin TextBox cPassword BackColor = &H00FFFFFF& Height = 285 Left = 1680 PasswordChar = "*" TabIndex = 3 Tag = "OL" Top = 1185 Width = 2655 End Begin CommandButton OkayButton BackColor = &H00C0C0C0& Caption = "&Open" Default = -1 'True Height = 375 Left = 300 TabIndex = 4 Top = 1680 Width = 1575 End Begin CommandButton CancelButton BackColor = &H00C0C0C0& Cancel = -1 'True Caption = "&Cancel" Height = 375 Left = 2460 TabIndex = 5 Top = 1680 Width = 1575 End Begin Label DataBaseLabel BackColor = &H00C0C0C0& Caption = "DataBase:" Height = 255 Left = 120 TabIndex = 9 Top = 465 Width = 1335 End Begin Label DBNameLabel BackColor = &H00C0C0C0& Caption = "Source/Server:" Height = 255 Left = 120 TabIndex = 6 Top = 105 Width = 1470 End Begin Label UserNameLabel BackColor = &H00C0C0C0& Caption = "User ID:" Height = 255 Left = 120 TabIndex = 7 Top = 825 Width = 1335 End Begin Label PasswordLabel BackColor = &H00C0C0C0& Caption = "Password:" Height = 255 Left = 120 TabIndex = 8 Top = 1170 Width = 1335 End Option Explicit Dim BeenLoaded As Integer '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 () On Error Resume Next 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 Else cDataBase.SetFocus End If End Sub Sub Form_Load () Left = (Screen.Width - Width) / 2 Top = (Screen.Height - Height) / 2 GetDataSources cDBName MsgBar "Enter DataBase Parameters", False BeenLoaded = True End Sub Sub Form_Paint () Outlines Me 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, DataSource 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 Connect = "ODBC;" If cUserName <> "" Then Connect = Connect + "UID=" + cUserName + ";PWD=" + cPassword End If If cDataBase <> "" Then Connect = Connect + ";DATABASE=" + cDataBase End If 'add login timeout Connect = Connect + ";LoginTimeout=" & glLoginTimeout DataSource = cDBName 'save the values gstDBName = cDBName gstDatabase = cDataBase gstUserName = cUserName gstPassword = cPassword gstDataType = "ODBC" Me.Hide Set gCurrentDB = OpenDatabase(DataSource, False, False, Connect) If gfDBOpenFlag = True Then CloseAllDynasets End If gfTransPending = False VDMDI.ToolBar.Visible = True VDMDI.QueryBuilder.Visible = True VDMDI.TblAttach.Visible = False fSQL.CreateQueryDefbtn.Visible = False 'process the connect string just in case the 'values came from the ODBC dialogs t = gCurrentDB.Connect If InStr(t, "=") Then i = 1 While i <= Len(t) + 1 If Mid(t, i, 1) = ";" Or i = Len(t) + 1 Then If s <> "" And InStr(s, "=") > 0 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)) Case Else 'nothing End Select End If s = "" Else s = s + Mid(t, i, 1) End If i = i + 1 Wend End If 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 = glQueryTimeout '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 glQueryTimeout <> 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 
(.txt)