#1
  1. No Profile Picture
    Contributing User
    Devshed Newbie (0 - 499 posts)

    Join Date
    Apr 2013
    Posts
    30
    Rep Power
    2

    Question Coding a Database navigation program


    Okay, I have used a tutorial on how to code a program that navigates through a database. However, my code just doesn't seem to work.

    Here's what I have so far:

    Code:
    Public Class Lab9_Lefelhocz
        Dim inc As Integer
        Dim MaxRows As Integer
        Dim da As OleDb.OleDbDataAdapter
        Dim dbprovider As String
        Dim dbsource As String
        Dim sql As String
        Dim con As New OleDb.OleDbConnection
    
    
    
        Private Sub VehicleBindingNavigatorSaveItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
            Me.Validate()
            Me.VehicleBindingSource.EndEdit()
            Me.TableAdapterManager.UpdateAll(Me.VBAutoDataSet)
    
        End Sub
    
        Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
            Me.VehicleTableAdapter.Fill(Me.VBAutoDataSet.Vehicle)
            dbprovider = "PROVIDER = Microsoft.Jet.OLEDB.4.0;"
            dbsource = "Data Source = C:\Users\jjpkjrl\VBAuto.mdb"
            con.ConnectionString = dbprovider & dbsource
            con.Open()
            sql = "SELECT * FROM TABLE VEHICLE"
            da = New OleDb.OleDbDataAdapter(sql, con)
            da.Fill(VBAutoDataSet, "VBAutoDataSet")
            MaxRows = VBAutoDataSet.Tables("Vehicle").Rows.Count
            inc = -1
            con.Close()
        End Sub
        Private Sub NavigateRecords()
    
            InventoryIDTextBox.Text = VBAutoDataSet.Tables("Vehicle").Rows(inc).Item(1)
            ManufacturerTextBox.Text = VBAutoDataSet.Tables("Vehicle").Rows(inc).Item(2)
            ModelNameTextBox.Text = VBAutoDataSet.Tables("Vehicle").Rows(inc).Item(3)
            YearTextBox.Text = VBAutoDataSet.Tables("Vehicle").Rows(inc).Item(4)
            VehicleIDTextBox.Text = VBAutoDataSet.Tables("Vehicle").Rows(inc).Item(5)
            CostValueTextBox.Text = VBAutoDataSet.Tables("Vehicle").Rows(inc).Item(6)
    
        End Sub
        Private Sub FirstButton_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
            If inc <> 0 Then
    
                inc = 0
    
                NavigateRecords()
    
            End If
        End Sub
    
        Private Sub PrevButton_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
            If inc > 0 Then
    
                inc = inc - 1
                NavigateRecords()
            End If
        End Sub
    
        Private Sub NextButton_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
            If inc <> MaxRows - 1 Then
    
                inc = inc + 1
                NavigateRecords()
            End If
        End Sub
    
        Private Sub LastButton_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
            If inc <> MaxRows - 1 Then
    
                inc = MaxRows - 1
                NavigateRecords()
            End If
        End Sub
    
    
    
    End Class
  2. #2
  3. No Profile Picture
    Contributing User
    Devshed Newbie (0 - 499 posts)

    Join Date
    Aug 2011
    Posts
    289
    Rep Power
    45
    I am not familiar with some of the code you are using, but here is an example using ADO and VB6:
    Code:
    Option Explicit
    
    Dim Inc As Integer
    Dim MaxRows As Integer
    'Dim da As OleDb.OleDbDataAdapter
    Dim dbprovider As String
    Dim dbsource As String
    Dim SQL As String
    Dim Con As ADODB.Connection
    Dim rstVehicles As ADODB.Recordset
    
    Private Sub NavigateRecords()
        txtInvID.Text = rstVehicles("InventoryID")
        txtMft.Text = rstVehicles("Manufacturer")
        txtModel.Text = rstVehicles("ModelName")
        txtYear.Text = rstVehicles("Year")
        txtVIN.Text = rstVehicles("VehicleID")
        txtCost.Text = Format(rstVehicles("CostValue"), "Currency")
        Me.Caption = "VB Auto Record " & CStr(rstVehicles.AbsolutePosition) & " of " & CStr(MaxRows)
    End Sub
    
    Private Sub cmdFirst_Click()
        If Not rstVehicles.BOF Then
            rstVehicles.MoveFirst
            Call NavigateRecords
        End If
    End Sub
    
    Private Sub cmdLast_Click()
        If Not rstVehicles.EOF Then
            rstVehicles.MoveLast
            Call NavigateRecords
        End If
    End Sub
    
    Private Sub cmdnext_Click()
        rstVehicles.MoveNext
        If rstVehicles.EOF Then
            'Restore prevoius position
            rstVehicles.MovePrevious
        Else
            Call NavigateRecords
        End If
    End Sub
    
    Private Sub cmdPrev_Click()
        rstVehicles.MovePrevious
        If rstVehicles.BOF Then
            'Restore previous position
            rstVehicles.MoveNext
        Else
            Call NavigateRecords
        End If
    End Sub
    
    Private Sub Form_Load()
        ' Open a connection
        Set Con = New ADODB.Connection
        dbprovider = "PROVIDER = Microsoft.Jet.OLEDB.4.0;"
        dbsource = "Data Source = " & App.Path & "\VBAuto.mdb"
        Con.Open dbprovider & dbsource
        ' Open Vehicles Table with a cursor that allows updates
        Set rstVehicles = New ADODB.Recordset
        SQL = "Vehicle"
        rstVehicles.Open SQL, Con, adOpenKeyset, adLockOptimistic, adCmdTable
        MaxRows = rstVehicles.RecordCount
        Call NavigateRecords
    End Sub
    J.A. Coutts
  4. #3
  5. No Profile Picture
    Contributing User
    Devshed Newbie (0 - 499 posts)

    Join Date
    Aug 2011
    Posts
    289
    Rep Power
    45
    Here is another example. This one uses a Data Control as well as ODBC and ADO. The Data Control replaces the four Command Buttons for navigation, and ODBC greatly simplifies the database connection. This routine detects whether or not the Data Set Name (DSN) exits, and if it does not, it creates it. I have included all of the form and module because the form setup is fairly important.
    Code:
    VERSION 5.00
    Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
    Begin VB.Form Form2 
       Caption         =   "Form2"
       ClientHeight    =   2295
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   7065
       LinkTopic       =   "Form1"
       ScaleHeight     =   2295
       ScaleWidth      =   7065
       StartUpPosition =   3  'Windows Default
       Begin MSAdodcLib.Adodc Adodc1 
          Height          =   375
          Left            =   0
          Top             =   1920
          Width           =   7095
          _ExtentX        =   12515
          _ExtentY        =   661
          ConnectMode     =   0
          CursorLocation  =   3
          IsolationLevel  =   -1
          ConnectionTimeout=   15
          CommandTimeout  =   30
          CursorType      =   3
          LockType        =   3
          CommandType     =   8
          CursorOptions   =   0
          CacheSize       =   50
          MaxRecords      =   0
          BOFAction       =   0
          EOFAction       =   0
          ConnectStringType=   3
          Appearance      =   1
          BackColor       =   -2147483643
          ForeColor       =   -2147483640
          Orientation     =   0
          Enabled         =   -1
          Connect         =   "DSN=VBAuto.mdb"
          OLEDBString     =   ""
          OLEDBFile       =   ""
          DataSourceName  =   "VBAuto.mdb"
          OtherAttributes =   ""
          UserName        =   ""
          Password        =   ""
          RecordSource    =   ""
          Caption         =   "Auto Database"
          BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
             Name            =   "MS Sans Serif"
             Size            =   8.25
             Charset         =   0
             Weight          =   400
             Underline       =   0   'False
             Italic          =   0   'False
             Strikethrough   =   0   'False
          EndProperty
          _Version        =   393216
       End
       Begin VB.Frame Frame1 
          BackColor       =   &H0080C0FF&
          Caption         =   "Automobile Information"
          Height          =   1935
          Left            =   0
          TabIndex        =   0
          Top             =   0
          Width           =   7095
          Begin VB.TextBox txtInvID 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   1440
             TabIndex        =   6
             Text            =   "Inv ID"
             Top             =   240
             Width           =   1215
          End
          Begin VB.TextBox txtMft 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   1440
             TabIndex        =   5
             Text            =   "Manufacturer"
             Top             =   720
             Width           =   2175
          End
          Begin VB.TextBox txtModel 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   4800
             TabIndex        =   4
             Text            =   "Model"
             Top             =   720
             Width           =   1695
          End
          Begin VB.TextBox txtYear 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   1440
             TabIndex        =   3
             Text            =   "Year"
             Top             =   1200
             Width           =   855
          End
          Begin VB.TextBox txtVIN 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   4320
             TabIndex        =   2
             Text            =   "Vehicle ID"
             Top             =   240
             Width           =   2175
          End
          Begin VB.TextBox txtCost 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   4200
             TabIndex        =   1
             Text            =   "Cost"
             Top             =   1200
             Width           =   1215
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Inventory ID:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   0
             Left            =   120
             TabIndex        =   12
             Top             =   240
             Width           =   1215
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Manufacturer:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   1
             Left            =   120
             TabIndex        =   11
             Top             =   720
             Width           =   1215
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Model:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   2
             Left            =   3960
             TabIndex        =   10
             Top             =   720
             Width           =   735
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Year:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   3
             Left            =   720
             TabIndex        =   9
             Top             =   1200
             Width           =   615
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Vehicle ID:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   4
             Left            =   3120
             TabIndex        =   8
             Top             =   240
             Width           =   1095
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Cost:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   5
             Left            =   3480
             TabIndex        =   7
             Top             =   1200
             Width           =   615
          End
       End
    End
    Attribute VB_Name = "Form2"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit
    
    Dim Database As String
    Dim ADOConnStr1 As String
    
    Public Function LocalInit() As Long
    ' Purpose:
    '   Starting point for application.
    ' =====================================================
        Dim HANDLE As Long
        Dim TaskID As Long
        Dim sSQL As String
        Dim sErr As Variant
        Dim Temp$
        Dim File$
        Dim Runfile%
        Dim N%
        Dim returnName As Collection
        Dim Count As Integer
        Const sProc As String = "LocalInit"
        Const ODBC_ADD_DSN = 1
        On Error GoTo LocalInitErr
        'Get INI file info
        Database = "VBAuto.mdb"
        'Verify database exists
        If Not GetDSN(Database, "Microsoft Access Driver (*.mdb)", App.Path & "\VBAuto.mdb", ODBC_ADD_DSN) Then
            Err.Raise 53 'File Not Found
        End If
        ADOConnStr1 = "DSN=" + Database + ";uid=;pwd=;database='Vehicles';"
        Set ADOConn1 = CreateObject("ADODB.Connection")
        ADOConn1.Open ADOConnStr1
        Adodc1.RecordSource = ""
        Adodc1.ConnectionString = ""
        Adodc1.ConnectionString = ADOConnStr1
    '    Adodc1.RecordSource = "SELECT ID, Msg_ID, R_Date, S, D, A, Sender, Subject FROM " _
            & TableName & " WHERE " & strSelect & " ORDER BY " & CStr(oSort) & strDirection & ";"
        Adodc1.RecordSource = "SELECT * FROM Vehicle;"
        Adodc1.Refresh
        If Adodc1.Recordset.Fields.Count > 0 Then
            Call DisplayRecords
    '        Set DataGrid1.DataSource = Adodc1.Recordset
    '        DataGrid1.ClearFields
    '        DataGrid1.ReBind
        End If
        LocalInit = False
        Exit Function
    LocalInitErr:
        sErr = Err
        LocalInit = sErr
    End Function
    Function RegQuery(sKeyBase As Long, sKeyName As String, sValueName As String) As String
        Dim lRetVal As Long
        Dim hKey As Long
        Dim vValue As Variant
        Dim cch As Long
        Dim lrc As Long
        Dim lType As Long
        Dim lValue As Long
        Dim sValue As String
        lRetVal = RegOpenKeyEx(sKeyBase, sKeyName, 0, KEY_READ, hKey)
        If lRetVal <> 0 Then
            RegQuery = "No Such Key as " + sKeyName
            Exit Function
        End If
        On Error GoTo RegQueryError
        lrc = RegQueryValueExNULL(hKey, sValueName, 0&, lType, 0&, cch)
        If lrc <> 0 Then Error 5
        Select Case lType
            Case REG_SZ
                sValue = String(cch, 0)
                lrc = RegQueryValueExString(hKey, sValueName, 0&, lType, sValue, cch)
                If lrc = 0 Then
                    vValue = Left$(sValue, cch - 1)
                Else
                    vValue = Empty
                End If
            Case REG_DWORD
                lrc = RegQueryValueExLong(hKey, sValueName, 0&, lType, lValue, cch)
                If lrc = 0 Then vValue = lValue
            Case REG_BINARY
                lrc = RegQueryValueExBinary(hKey, sValueName, 0&, lType, lValue, cch)
                If lrc = 0 Then vValue = lValue
            Case Else
                lrc = -1
        End Select
    RegQueryExit:
        RegQuery = vValue
        RegCloseKey (hKey)
        Exit Function
    RegQueryError:
        Resume RegQueryExit
    End Function
    Private Sub DisplayRecords()
        txtInvID.Text = Adodc1.Recordset("InventoryID")
        txtMft.Text = Adodc1.Recordset("Manufacturer")
        txtModel.Text = Adodc1.Recordset("ModelName")
        txtYear.Text = Adodc1.Recordset("Year")
        txtVIN.Text = Adodc1.Recordset("VehicleID")
        txtCost.Text = Format(Adodc1.Recordset("CostValue"), "Currency")
        Me.Caption = "VB Auto Record " & CStr(Adodc1.Recordset.AbsolutePosition) & " of " & CStr(Adodc1.Recordset.RecordCount)
    End Sub
    
    Public Function GetDSN(sDSN As String, sDriver As String, sDBFile As String, lAction As Long) As Long
        Dim sAttributes As String
        Dim sDBQ As String
        Dim lngRet As Long
        Dim hKey As Long
        Dim regValue As String
        Dim valueType As Long
        ' query the Registry to check whether the DSN is already installed
        ' open the key
        sDBQ = RegQuery(HKEY_CURRENT_USER, "SOFTWARE\ODBC\ODBC.INI\" + sDSN, "DBQ")
        If Left$(sDBQ, 11) = "No Such Key" Then
            If Len(sDBFile) Then 'File path/name supplied
                lngRet = MsgBox(sDBQ & vbCrLf & "CREATE IT?", vbYesNo)
                If lngRet = vbYes Then
                    sDBQ = ""
                Else
                    'Routine failed
                    GetDSN = False
                    Exit Function
                End If
            Else 'No file name supplied
                GetDSN = False
                Exit Function
            End If
        End If
        If Len(sDBQ) Then 'DBQ found
            If lAction = ODBC_ADD_DSN Then
                'Verify file actually exists
                If Len(Dir$(sDBFile)) Then
                    'Simply return DBQ
                    sDBFile = sDBQ
                    GetDSN = True
                    Exit Function
                Else 'return error
                    GetDSN = False
                    Exit Function
                End If
            Else 'Delete it
                sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar
                lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes)
            End If
        Else 'Add it
            ' check that the file actually exists
            If Len(sDBFile) > 0 And Len(Dir$(sDBFile)) Then 'create DSN
                 sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar
                 lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes)
             Else 'Return with error
                 MsgBox "Database file doesn't exist!", vbOKOnly + vbCritical
                 GetDSN = False
                 Exit Function
             End If
        End If
        If lngRet Then
            GetDSN = True
        Else
            GetDSN = False
        End If
    End Function
    
    
    Private Sub Adodc1_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
        Dim sMessage As String
        Select Case adReason
            Case adRsnAddNew
                Debug.Print "Adding New Record" & Str$(adReason)
            Case adRsnClose
                Debug.Print "Closing Recordset" & Str$(adReason)
            Case adRsnDelete
                Debug.Print "Deleting Record" & Str$(adReason)
            Case adRsnFirstChange
                Debug.Print "First Change" & Str$(adReason)
            Case adRsnMove
                Debug.Print "Move" & Str$(adReason)
                Call DisplayRecords
            Case adRsnMoveFirst
                Debug.Print "Move First Record" & Str$(adReason)
                Call DisplayRecords
            Case adRsnMoveLast
                Debug.Print "Move Last Record" & Str$(adReason)
                Call DisplayRecords
            Case adRsnMoveNext
                Debug.Print "Move Next Record" & Str$(adReason)
                If Not pRecordset.EOF Then Call DisplayRecords
            Case adRsnMovePrevious
                Debug.Print "Move Previous" & Str$(adReason)
                If Not pRecordset.BOF Then Call DisplayRecords
            Case adRsnRequery
                Debug.Print "Requering" & Str$(adReason)
            Case adRsnResynch
                Debug.Print "Resynch" & Str$(adReason)
            Case adRsnUndoAddNew
                Debug.Print "Undo Adding New Record" & Str$(adReason)
            Case adRsnUndoUpdate
                Debug.Print "Undoing Update" & Str$(adReason)
            Case adRsnUpdate
                Debug.Print "Updating record" & Str$(adReason)
        End Select
    End Sub
    
    Private Sub Adodc1_RecordChangeComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
        Debug.Print "Record Change Complete"
    End Sub
    
    Private Sub Form_Load()
        Call LocalInit
    End Sub
    Code:
    Attribute VB_Name = "Module1"
    Option Explicit
    
    Public Const gsDelimiter As String = "|"
    Private Const msModule As String = "Module1"
    Public Const HKEY_CURRENT_USER = &H80000001
    Public Const KEY_READ = &H19
    Public Const REG_SZ As Long = 1
    Public Const REG_DWORD As Long = 4
    Public Const REG_BINARY As Long = 3
    Public Const ODBC_ADD_DSN = 1      ' Add user data source
    Public ADOConn1 As ADODB.Connection
    
    Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
    Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
    Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
    Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
    Declare Function RegQueryValueExBinary Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
    Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Declare Function SQLConfigDataSource Lib "odbccp32.dll" (ByVal hWndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
    
    Public Function GetLocalData(vKeys As Variant, _
       vData As Variant, vExceptions As Variant) As Boolean
    ' Purpose:
    '   Passed a SQL statement in vKeys, retrieve a result-
    '   set and return it in vData.
    ' =====================================================
        Dim sErr As String
        Dim sSQL As String
        Dim SnapVen As New ADODB.Recordset
        Const sProc As String = "GetLocalData"
        On Error GoTo GetDataErr
        sSQL = vKeys
        SnapVen.Open sSQL, ADOConn1
        If Not SnapVen.EOF Then
            vData = SnapVen.GetRows(SnapVen.RecordCount)
            GetLocalData = True  'Success
        End If
        vExceptions = ""
        SnapVen.Close
        Exit Function
    GetDataErr:
        sErr = Err.Number & gsDelimiter & msModule _
          & gsDelimiter & sProc & gsDelimiter & Err.Description
    '    Call LogError(sErr)
        vExceptions = sErr
        SnapVen.Close
    End Function
    J.A. Coutts
  6. #4
  7. No Profile Picture
    Contributing User
    Devshed Newbie (0 - 499 posts)

    Join Date
    Apr 2013
    Posts
    30
    Rep Power
    2

    Talking Thanks


    Originally Posted by couttsj
    Here is another example. This one uses a Data Control as well as ODBC and ADO. The Data Control replaces the four Command Buttons for navigation, and ODBC greatly simplifies the database connection. This routine detects whether or not the Data Set Name (DSN) exits, and if it does not, it creates it. I have included all of the form and module because the form setup is fairly important.
    Code:
    VERSION 5.00
    Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
    Begin VB.Form Form2 
       Caption         =   "Form2"
       ClientHeight    =   2295
       ClientLeft      =   60
       ClientTop       =   345
       ClientWidth     =   7065
       LinkTopic       =   "Form1"
       ScaleHeight     =   2295
       ScaleWidth      =   7065
       StartUpPosition =   3  'Windows Default
       Begin MSAdodcLib.Adodc Adodc1 
          Height          =   375
          Left            =   0
          Top             =   1920
          Width           =   7095
          _ExtentX        =   12515
          _ExtentY        =   661
          ConnectMode     =   0
          CursorLocation  =   3
          IsolationLevel  =   -1
          ConnectionTimeout=   15
          CommandTimeout  =   30
          CursorType      =   3
          LockType        =   3
          CommandType     =   8
          CursorOptions   =   0
          CacheSize       =   50
          MaxRecords      =   0
          BOFAction       =   0
          EOFAction       =   0
          ConnectStringType=   3
          Appearance      =   1
          BackColor       =   -2147483643
          ForeColor       =   -2147483640
          Orientation     =   0
          Enabled         =   -1
          Connect         =   "DSN=VBAuto.mdb"
          OLEDBString     =   ""
          OLEDBFile       =   ""
          DataSourceName  =   "VBAuto.mdb"
          OtherAttributes =   ""
          UserName        =   ""
          Password        =   ""
          RecordSource    =   ""
          Caption         =   "Auto Database"
          BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
             Name            =   "MS Sans Serif"
             Size            =   8.25
             Charset         =   0
             Weight          =   400
             Underline       =   0   'False
             Italic          =   0   'False
             Strikethrough   =   0   'False
          EndProperty
          _Version        =   393216
       End
       Begin VB.Frame Frame1 
          BackColor       =   &H0080C0FF&
          Caption         =   "Automobile Information"
          Height          =   1935
          Left            =   0
          TabIndex        =   0
          Top             =   0
          Width           =   7095
          Begin VB.TextBox txtInvID 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   1440
             TabIndex        =   6
             Text            =   "Inv ID"
             Top             =   240
             Width           =   1215
          End
          Begin VB.TextBox txtMft 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   1440
             TabIndex        =   5
             Text            =   "Manufacturer"
             Top             =   720
             Width           =   2175
          End
          Begin VB.TextBox txtModel 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   4800
             TabIndex        =   4
             Text            =   "Model"
             Top             =   720
             Width           =   1695
          End
          Begin VB.TextBox txtYear 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   1440
             TabIndex        =   3
             Text            =   "Year"
             Top             =   1200
             Width           =   855
          End
          Begin VB.TextBox txtVIN 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   4320
             TabIndex        =   2
             Text            =   "Vehicle ID"
             Top             =   240
             Width           =   2175
          End
          Begin VB.TextBox txtCost 
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   285
             Left            =   4200
             TabIndex        =   1
             Text            =   "Cost"
             Top             =   1200
             Width           =   1215
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Inventory ID:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   0
             Left            =   120
             TabIndex        =   12
             Top             =   240
             Width           =   1215
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Manufacturer:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   1
             Left            =   120
             TabIndex        =   11
             Top             =   720
             Width           =   1215
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Model:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   2
             Left            =   3960
             TabIndex        =   10
             Top             =   720
             Width           =   735
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Year:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   3
             Left            =   720
             TabIndex        =   9
             Top             =   1200
             Width           =   615
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Vehicle ID:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   4
             Left            =   3120
             TabIndex        =   8
             Top             =   240
             Width           =   1095
          End
          Begin VB.Label lblDB 
             Alignment       =   1  'Right Justify
             BackColor       =   &H0080C0FF&
             Caption         =   "Cost:"
             BeginProperty Font 
                Name            =   "MS Sans Serif"
                Size            =   9.75
                Charset         =   0
                Weight          =   400
                Underline       =   0   'False
                Italic          =   0   'False
                Strikethrough   =   0   'False
             EndProperty
             Height          =   255
             Index           =   5
             Left            =   3480
             TabIndex        =   7
             Top             =   1200
             Width           =   615
          End
       End
    End
    Attribute VB_Name = "Form2"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit
    
    Dim Database As String
    Dim ADOConnStr1 As String
    
    Public Function LocalInit() As Long
    ' Purpose:
    '   Starting point for application.
    ' =====================================================
        Dim HANDLE As Long
        Dim TaskID As Long
        Dim sSQL As String
        Dim sErr As Variant
        Dim Temp$
        Dim File$
        Dim Runfile%
        Dim N%
        Dim returnName As Collection
        Dim Count As Integer
        Const sProc As String = "LocalInit"
        Const ODBC_ADD_DSN = 1
        On Error GoTo LocalInitErr
        'Get INI file info
        Database = "VBAuto.mdb"
        'Verify database exists
        If Not GetDSN(Database, "Microsoft Access Driver (*.mdb)", App.Path & "\VBAuto.mdb", ODBC_ADD_DSN) Then
            Err.Raise 53 'File Not Found
        End If
        ADOConnStr1 = "DSN=" + Database + ";uid=;pwd=;database='Vehicles';"
        Set ADOConn1 = CreateObject("ADODB.Connection")
        ADOConn1.Open ADOConnStr1
        Adodc1.RecordSource = ""
        Adodc1.ConnectionString = ""
        Adodc1.ConnectionString = ADOConnStr1
    '    Adodc1.RecordSource = "SELECT ID, Msg_ID, R_Date, S, D, A, Sender, Subject FROM " _
            & TableName & " WHERE " & strSelect & " ORDER BY " & CStr(oSort) & strDirection & ";"
        Adodc1.RecordSource = "SELECT * FROM Vehicle;"
        Adodc1.Refresh
        If Adodc1.Recordset.Fields.Count > 0 Then
            Call DisplayRecords
    '        Set DataGrid1.DataSource = Adodc1.Recordset
    '        DataGrid1.ClearFields
    '        DataGrid1.ReBind
        End If
        LocalInit = False
        Exit Function
    LocalInitErr:
        sErr = Err
        LocalInit = sErr
    End Function
    Function RegQuery(sKeyBase As Long, sKeyName As String, sValueName As String) As String
        Dim lRetVal As Long
        Dim hKey As Long
        Dim vValue As Variant
        Dim cch As Long
        Dim lrc As Long
        Dim lType As Long
        Dim lValue As Long
        Dim sValue As String
        lRetVal = RegOpenKeyEx(sKeyBase, sKeyName, 0, KEY_READ, hKey)
        If lRetVal <> 0 Then
            RegQuery = "No Such Key as " + sKeyName
            Exit Function
        End If
        On Error GoTo RegQueryError
        lrc = RegQueryValueExNULL(hKey, sValueName, 0&, lType, 0&, cch)
        If lrc <> 0 Then Error 5
        Select Case lType
            Case REG_SZ
                sValue = String(cch, 0)
                lrc = RegQueryValueExString(hKey, sValueName, 0&, lType, sValue, cch)
                If lrc = 0 Then
                    vValue = Left$(sValue, cch - 1)
                Else
                    vValue = Empty
                End If
            Case REG_DWORD
                lrc = RegQueryValueExLong(hKey, sValueName, 0&, lType, lValue, cch)
                If lrc = 0 Then vValue = lValue
            Case REG_BINARY
                lrc = RegQueryValueExBinary(hKey, sValueName, 0&, lType, lValue, cch)
                If lrc = 0 Then vValue = lValue
            Case Else
                lrc = -1
        End Select
    RegQueryExit:
        RegQuery = vValue
        RegCloseKey (hKey)
        Exit Function
    RegQueryError:
        Resume RegQueryExit
    End Function
    Private Sub DisplayRecords()
        txtInvID.Text = Adodc1.Recordset("InventoryID")
        txtMft.Text = Adodc1.Recordset("Manufacturer")
        txtModel.Text = Adodc1.Recordset("ModelName")
        txtYear.Text = Adodc1.Recordset("Year")
        txtVIN.Text = Adodc1.Recordset("VehicleID")
        txtCost.Text = Format(Adodc1.Recordset("CostValue"), "Currency")
        Me.Caption = "VB Auto Record " & CStr(Adodc1.Recordset.AbsolutePosition) & " of " & CStr(Adodc1.Recordset.RecordCount)
    End Sub
    
    Public Function GetDSN(sDSN As String, sDriver As String, sDBFile As String, lAction As Long) As Long
        Dim sAttributes As String
        Dim sDBQ As String
        Dim lngRet As Long
        Dim hKey As Long
        Dim regValue As String
        Dim valueType As Long
        ' query the Registry to check whether the DSN is already installed
        ' open the key
        sDBQ = RegQuery(HKEY_CURRENT_USER, "SOFTWARE\ODBC\ODBC.INI\" + sDSN, "DBQ")
        If Left$(sDBQ, 11) = "No Such Key" Then
            If Len(sDBFile) Then 'File path/name supplied
                lngRet = MsgBox(sDBQ & vbCrLf & "CREATE IT?", vbYesNo)
                If lngRet = vbYes Then
                    sDBQ = ""
                Else
                    'Routine failed
                    GetDSN = False
                    Exit Function
                End If
            Else 'No file name supplied
                GetDSN = False
                Exit Function
            End If
        End If
        If Len(sDBQ) Then 'DBQ found
            If lAction = ODBC_ADD_DSN Then
                'Verify file actually exists
                If Len(Dir$(sDBFile)) Then
                    'Simply return DBQ
                    sDBFile = sDBQ
                    GetDSN = True
                    Exit Function
                Else 'return error
                    GetDSN = False
                    Exit Function
                End If
            Else 'Delete it
                sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar
                lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes)
            End If
        Else 'Add it
            ' check that the file actually exists
            If Len(sDBFile) > 0 And Len(Dir$(sDBFile)) Then 'create DSN
                 sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar
                 lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes)
             Else 'Return with error
                 MsgBox "Database file doesn't exist!", vbOKOnly + vbCritical
                 GetDSN = False
                 Exit Function
             End If
        End If
        If lngRet Then
            GetDSN = True
        Else
            GetDSN = False
        End If
    End Function
    
    
    Private Sub Adodc1_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
        Dim sMessage As String
        Select Case adReason
            Case adRsnAddNew
                Debug.Print "Adding New Record" & Str$(adReason)
            Case adRsnClose
                Debug.Print "Closing Recordset" & Str$(adReason)
            Case adRsnDelete
                Debug.Print "Deleting Record" & Str$(adReason)
            Case adRsnFirstChange
                Debug.Print "First Change" & Str$(adReason)
            Case adRsnMove
                Debug.Print "Move" & Str$(adReason)
                Call DisplayRecords
            Case adRsnMoveFirst
                Debug.Print "Move First Record" & Str$(adReason)
                Call DisplayRecords
            Case adRsnMoveLast
                Debug.Print "Move Last Record" & Str$(adReason)
                Call DisplayRecords
            Case adRsnMoveNext
                Debug.Print "Move Next Record" & Str$(adReason)
                If Not pRecordset.EOF Then Call DisplayRecords
            Case adRsnMovePrevious
                Debug.Print "Move Previous" & Str$(adReason)
                If Not pRecordset.BOF Then Call DisplayRecords
            Case adRsnRequery
                Debug.Print "Requering" & Str$(adReason)
            Case adRsnResynch
                Debug.Print "Resynch" & Str$(adReason)
            Case adRsnUndoAddNew
                Debug.Print "Undo Adding New Record" & Str$(adReason)
            Case adRsnUndoUpdate
                Debug.Print "Undoing Update" & Str$(adReason)
            Case adRsnUpdate
                Debug.Print "Updating record" & Str$(adReason)
        End Select
    End Sub
    
    Private Sub Adodc1_RecordChangeComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
        Debug.Print "Record Change Complete"
    End Sub
    
    Private Sub Form_Load()
        Call LocalInit
    End Sub
    Code:
    Attribute VB_Name = "Module1"
    Option Explicit
    
    Public Const gsDelimiter As String = "|"
    Private Const msModule As String = "Module1"
    Public Const HKEY_CURRENT_USER = &H80000001
    Public Const KEY_READ = &H19
    Public Const REG_SZ As Long = 1
    Public Const REG_DWORD As Long = 4
    Public Const REG_BINARY As Long = 3
    Public Const ODBC_ADD_DSN = 1      ' Add user data source
    Public ADOConn1 As ADODB.Connection
    
    Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
    Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
    Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
    Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
    Declare Function RegQueryValueExBinary Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
    Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Declare Function SQLConfigDataSource Lib "odbccp32.dll" (ByVal hWndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
    
    Public Function GetLocalData(vKeys As Variant, _
       vData As Variant, vExceptions As Variant) As Boolean
    ' Purpose:
    '   Passed a SQL statement in vKeys, retrieve a result-
    '   set and return it in vData.
    ' =====================================================
        Dim sErr As String
        Dim sSQL As String
        Dim SnapVen As New ADODB.Recordset
        Const sProc As String = "GetLocalData"
        On Error GoTo GetDataErr
        sSQL = vKeys
        SnapVen.Open sSQL, ADOConn1
        If Not SnapVen.EOF Then
            vData = SnapVen.GetRows(SnapVen.RecordCount)
            GetLocalData = True  'Success
        End If
        vExceptions = ""
        SnapVen.Close
        Exit Function
    GetDataErr:
        sErr = Err.Number & gsDelimiter & msModule _
          & gsDelimiter & sProc & gsDelimiter & Err.Description
    '    Call LogError(sErr)
        vExceptions = sErr
        SnapVen.Close
    End Function
    J.A. Coutts
    I got my code to work, though I will keep a record of this code if I want to make another program like this. Thank you again.

IMN logo majestic logo threadwatch logo seochat tools logo