SampleDatabase Projects. Download

The projects (one using DAO code, the other using ADOX and ADO) are very simple, and designed to provide an introduction to database programming using code rather than the intrinsic DAO data control or ADODC data control. They are ideal for those people who are familiar with the controls, but want to progress to code -based data access. These controls have the advantage of taking care of updating and displaying the fields of the database automatically as you move from one record to another using built in navigation buttons on the controls. Both projects use the appropriate data control in the display of data on a bound Flexgrid control, to show how they are useful, even on a code-based project. The DAO project uses a Data Control and MSFlexgrid. The ADO project uses a ADODC data control with MSHFlexgrid.

When you start the project you are presented with this screen. you cannot do anything until the database has been either created, or connected to using the Open / Create Database button

Here is the code for both versions of the project

Module modDatabase (DAO version) Used for declaring Public Database variables:

Option Explicit

'declare database variables as Public in a code module
'Then any form can use them.
Public db As DAO.Database
Public rs As DAO.Recordset

Modulre modDatabaseADO (ADO version)

Option Explicit

'declare database variables as Public in a code module
'Then any form can use them.
Public cat As New ADOX.Catalog
Public cnn As New ADODB.Connection
Public rs As New ADODB.Recordset

Form Load Event (Same in both Projects)

Private Sub Form_Load()
    'centre form on screen
    Me.Top = (Screen.Height - Me.Height) \ 2
    Me.Left = (Screen.Width - Me.Width) \ 2
End Sub

Create / Open Database Command Button

DAO version

Private Sub cmdCreate_Click()
    Dim tDef As DAO.TableDef
    Dim Fd As DAO.Field
    Dim iX As DAO.Index
    
    'check if database already present
    If Dir$(App.Path & "\SampleDatabase.mdb") <> "" Then
        'database alredy present so open it
        Set db = OpenDatabase(App.Path & "\SampleDatabase.mdb")
        
        'open a recordset
        Set rs = db.OpenRecordset("TestTable", dbOpenDynaset)
        MsgBox "Existing Database " & App.Path & "\SampleDatabase.mdb" & " is now open..."
    Else
        'create database
        Set db = CreateDatabase(App.Path & "\SampleDatabase.mdb", dbLangGeneral)
        'create table
        Set tDef = db.CreateTableDef("TestTable")
    
        'create fields
        Set Fd = tDef.CreateField("ID", dbLong)
        'make it Autonumber
        Fd.Attributes = dbAutoIncrField
        tDef.Fields.Append Fd
        
        'create text field called "Surname"
        Set Fd = tDef.CreateField("Surname", dbText, 50)
        'Allow storage of empty field.
        'If this is not set, a space has to be inserted in before an .Update is allowed
        Fd.AllowZeroLength = True
        tDef.Fields.Append Fd
        
        Set Fd = tDef.CreateField("FirstName", dbText, 50)
        Fd.AllowZeroLength = True
        tDef.Fields.Append Fd
        
        Set Fd = tDef.CreateField("Address", dbText, 150)
        Fd.AllowZeroLength = True
        tDef.Fields.Append Fd
        
        'create Primary Index
        Set iX = tDef.CreateIndex("ID")
        iX.IgnoreNulls = False
        iX.Primary = True
        iX.Required = True
        iX.Unique = True
        'Define Index field(s)
        Set Fd = iX.CreateField("ID")
        iX.Fields.Append Fd
        'append index
        tDef.Indexes.Append iX
        'append table
        db.TableDefs.Append tDef
        
        'open new table
        Set rs = db.OpenRecordset("TestTable", dbOpenDynaset)
        
        'now add some data
        rs.AddNew
        'shorthand method
        rs!Surname = "Smith"
        'longhand method to do same thing
        rs.Fields("FirstName").Value = "Fred"
        rs!Address = "1 The Street" & vbCrLf & "AnyTown"
        rs.Update
        
        rs.AddNew
        rs!Surname = "Smith"
        rs!FirstName = "Rita"
        rs!Address = "1 The Street" & vbCrLf & "AnyTown"
        rs.Update
        
        rs.AddNew
        rs!Surname = "Jones"
        rs!FirstName = "Harold"
        rs!Address = "1 The Road" & vbCrLf & "This City"
        rs.Update
        
        rs.AddNew
        rs!Surname = "Archer"
        rs!FirstName = "John"
        rs!Address = "4 The Avenue" & vbCrLf & "The Village" & vbCrLf & "A County"
        rs.Update
        
        MsgBox "New Database " & App.Path & "\SampleDatabase.mdb" & " has been created and is now open..."
    End If
    'now enable command buttons to navigate recordset
    Dim MyCmd As Control
    For Each MyCmd In Me
        MyCmd.Enabled = True
    Next MyCmd
    'disable this command button as database now open
    cmdCreate.Enabled = False
    'now display first record
    

    If rs.BOF Then
        'empty database so add new and redisplay
        rs.AddNew
        'update it immediately
        rs.Update
        'now find it again
        rs.Bookmark = rs.LastModified
        'fields are empty so textboxes automatically cleared
        DisplayRecord
        MsgBox "Empty database, please complete details of first (New) record"
    Else
        rs.MoveFirst
        'call Sub to fill text boxes with data
        DisplayRecord
    End If

ADO Version:

Private Sub cmdCreate_Click()
    Dim tbl As New ADOX.Table
    Dim col As ADOX.Column
    Dim iX As ADOX.Index
    
    'check if database already present
    If Dir$(App.Path & "\SampleDatabase.mdb") <> "" Then
        'database alredy present so open it
        cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\SampleDatabase.mdb"
        'set catalog
        cat.ActiveConnection = cnn
        'open a recordset
        rs.Open "TestTable", cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
        MsgBox "Existing Database " & App.Path & "\SampleDatabase.mdb" & " is now open..."
    Else
        'create database
        cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\SampleDatabase.mdb"

        'create table
        tbl.Name = "TestTable"
        'append table
        cat.Tables.Append tbl
        
        ' Create fields and append them to the
        ' Columns collection of the new Table object.
        With tbl
            Set col = New ADOX.Column
            With col
                .Name = "ID"
                .Type = adInteger
                'refer to parent catalog to allow autonumber to be set up
                Set .ParentCatalog = cat
                'Make it Autonumber
                .Properties("AutoIncrement") = True
                .SortOrder = adSortAscending
            End With
            .Columns.Append col
            Set col = Nothing
            
            'create text field called "Surname"
            Set col = New ADOX.Column
            With col
                .Name = "Surname"
                .DefinedSize = 50
                .Type = adVarWChar
                .Attributes = adColNullable
                .SortOrder = adSortAscending
            End With
            .Columns.Append col
            Set col = Nothing
            'allow zero length field
            .Columns("Surname").Properties("Jet OLEDB:Allow Zero Length") = True
        
            'create text field called "FirstName"
            Set col = New ADOX.Column
            With col
                .Name = "FirstName"
                .DefinedSize = 50
                .Type = adVarWChar
                .Attributes = adColNullable
                .SortOrder = adSortAscending
            End With
            .Columns.Append col
            Set col = Nothing
            'allow zero length field
            .Columns("FirstName").Properties("Jet OLEDB:Allow Zero Length") = True
        
            'create text field called "Address"
            Set col = New ADOX.Column
            With col
                .Name = "Address"
                .DefinedSize = 150
                .Type = adVarWChar
                .Attributes = adColNullable
                .SortOrder = adSortAscending
            End With
            .Columns.Append col
            Set col = Nothing
            'allow zero length field
            .Columns("Address").Properties("Jet OLEDB:Allow Zero Length") = True
        
            'create Primary Index
            Set iX = New ADOX.Index
            With iX
              .PrimaryKey = True
              .Unique = True
              .IndexNulls = adIndexNullsDisallow
              .Name = "ID"
              'Define Index field(s)
              .Columns.Append "ID"
            End With
            'append index
            .Indexes.Append iX
        End With
        Set tbl = Nothing
    
        'now add some data
        'open new table
        cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\SampleDatabase.mdb"
        rs.Open "TestTable", cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
        cat.ActiveConnection = cnn
        'now add some data
        rs.AddNew
        'shorthand method
        rs!Surname = "Smith"
        'longhand method to do same thing
        rs.Fields("FirstName").Value = "Fred"
        rs!Address = "1 The Street" & vbCrLf & "AnyTown"
        rs.Update
        
        rs.AddNew
        rs!Surname = "Smith"
        rs!FirstName = "Rita"
        rs!Address = "1 The Street" & vbCrLf & "AnyTown"
        rs.Update
        
        rs.AddNew
        rs!Surname = "Jones"
        rs!FirstName = "Harold"
        rs!Address = "1 The Road" & vbCrLf & "This City"
        rs.Update
        
        rs.AddNew
        rs!Surname = "Archer"
        rs!FirstName = "John"
        rs!Address = "4 The Avenue" & vbCrLf & "The Village" & vbCrLf & "A County"
        rs.Update
        
        MsgBox "New Database " & App.Path & "\SampleDatabase.mdb" & " has been created and is now open..."
    End If
    'now enable command buttons to navigate recordset
    Dim MyCmd As Control
    For Each MyCmd In Me
        MyCmd.Enabled = True
    Next MyCmd
    'disable this command button as database now open
    cmdCreate.Enabled = False
    'now display first record

    If rs.BOF Then
        'empty database so add new and redisplay
        rs.AddNew
        lID = rs!ID
        'update it immediately
        rs.Update
        'now find it again
        rs.Find "ID = " & lID
        'fields are empty so textboxes automatically cleared
        DisplayRecord
        MsgBox "Empty database, please complete details of first (New) record"
    Else
        rs.MoveFirst
        'call Sub to fill text boxes with data
        DisplayRecord
    End If

Navigation Buttons (Both versions)

Private Sub cmdMoveFirst_Click()
    'save any pending changes to current record
    UpdateRecord
    rs.MoveFirst
    DisplayRecord
End Sub

Private Sub cmdMoveLast_Click()
    'save any pending changes to current record
    UpdateRecord
    rs.MoveLast
    DisplayRecord
End Sub

Private Sub cmdMoveNext_Click()
    'save any pending changes to current record
    UpdateRecord
    rs.MoveNext
    'may be already on last record, so check if moved past end of file
    If rs.EOF Then
        rs.MoveLast
    End If
    DisplayRecord
End Sub

Private Sub cmdMovePrevious_Click()
    'save any pending changes to current record
    UpdateRecord
    rs.MovePrevious
    'may be already on first record, so check if moved past start of file
    If rs.BOF Then
        rs.MoveFirst
    End If
    DisplayRecord
End Sub

Public Sub DisplayRecord()
    'fill textboxes with data
    txtID = rs!ID
    'add & "" to prevent errors if the field value = Null
    txtSurname = rs!Surname & ""
    'shorthand version
    txtFirstName = rs!FirstName & ""
    'longhand version
    txtAddress = rs.Fields("Address").Value & ""
End Sub

UpdateRecord (DAO Version)

Public Sub UpdateRecord()
    'start edit of existing record
    rs.Edit
    'alter values of fields
    rs!Surname = txtSurname
    rs!FirstName = txtFirstName
    rs!Address = txtAddress
    'update changes
    rs.Update
End Sub

UpdateRecord (ADO Version)

Public Sub UpdateRecord()
    'alter values of fields
    rs!Surname = txtSurname
    rs!FirstName = txtFirstName
    rs!Address = txtAddress
    'update changes
    rs.Update
End Sub

Add New Record (DAO Version)

Public Sub AddNewRecord()
    'save any pending changes to current record
    UpdateRecord
    'Add a new record. Autonumber fields are inserted by Jet Engine
    rs.AddNew
    'update it immediately
    rs.Update
    'now find it again
    rs.Bookmark = rs.LastModified
    'fields are empty so textboxes automatically cleared
    DisplayRecord
End Sub

Add New Record (ADO Version)

Public Sub AddNewRecord()
    Dim lID As Long
    'save any pending changes to current record
    UpdateRecord
    'Add a new record. Autonumber fields are inserted by Jet Engine
    rs.AddNew
    lID = rs!ID
    'update it immediately
    rs.Update
    'now find it again
    rs.Find "ID = " & lID
    'fields are empty so textboxes automatically cleared
    DisplayRecord
End Sub

FindFirst (DAO)

Private Sub cmdFind_Click()
    Dim strBookMark As String
    
    If txtFind.Text <> "" Then
        'update current record before moving off
        UpdateRecord
        'save current record position
        strBookMark = rs.Bookmark
        'search for value in text box
        rs.FindFirst "Surname =  '" & txtFind.Text & "'"
        If rs.NoMatch Then
            MsgBox "No record found"
            'restore record to previous position
            rs.Bookmark = strBookMark
        Else
            DisplayRecord
        End If
    Else
        MsgBox "Enter a Surname to search for!"
        txtFind.SetFocus
    End If
End Sub

Find (ADO)

Private Sub cmdFind_Click()
    Dim strBookMark As Variant
    
    If txtFind.Text <> "" Then
        'update current record before moving off
        UpdateRecord
        'save current record position
        strBookMark = rs.Bookmark
        'search for value in text box
        rs.Find "Surname =  '" & txtFind.Text & "'"
        If rs.EOF Then
            MsgBox "No record found"
            'restore record to previous position
            rs.Bookmark = strBookMark
        Else
            DisplayRecord
        End If
    Else
        MsgBox "Enter a Surname to search for!"
        txtFind.SetFocus
    End If
End Sub

Add Table (DAO Version)

Private Sub cmdAddTable_Click()
    Dim tDef As DAO.TableDef
    Dim Fd As DAO.Field
    Dim iX As DAO.Index
    
    If txtTableName.Text = "" Then
        MsgBox "Enter a name for the new table!"
        txtTableName.SetFocus
    Else
        'Check existing Table names
        For Each tDef In db.TableDefs
            If tDef.Name = txtTableName.Text Then
                MsgBox "A Table of this name already exists!", vbExclamation + vbOKOnly
                Exit Sub
            End If
        Next tDef
        
        'create new table
        Set tDef = db.CreateTableDef(txtTableName.Text)
    
        'create just one field
        Set Fd = tDef.CreateField("ID", dbLong)
        
        'make it Autonumber
        Fd.Attributes = dbAutoIncrField
        tDef.Fields.Append Fd
    
        db.TableDefs.Append tDef

        MsgBox "New Table " & txtTableName.Text & " has been added. Use Access to view"
    End If
End Sub

Add Table (ADOX Version)

Private Sub cmdAddTable_Click()
    Dim tbl As ADOX.Table
    Dim col As ADOX.Column
    Dim iX As ADOX.Index
    
    If txtTableName.Text = "" Then
        MsgBox "Enter a name for the new table!"
        txtTableName.SetFocus
    Else
        'Check existing Table names
        
        For Each tbl In cat.Tables
            If UCase(tbl.Name) = UCase(txtTableName.Text) Then
                MsgBox "A Table of this name already exists!", vbExclamation + vbOKOnly
                Exit Sub
            End If
        Next tbl
        
        'create new table
        Set tbl = New ADOX.Table
        tbl.Name = txtTableName.Text
        cat.Tables.Append tbl
        
        'create just one field
        Set col = New ADOX.Column
        With col
            .Name = "ID"
            .Type = adInteger
            Set .ParentCatalog = cat
            'Make it Autonumber
            .Properties("AutoIncrement") = True
            .SortOrder = adSortAscending
        End With
        tbl.Columns.Append col
        Set col = Nothing
    
        MsgBox "New Table " & txtTableName.Text & " has been added. Use Access to view"
    End If
End Sub