
'----------------------------------------------------------------
' Hands-On 11-1
'----------------------------------------------------------------

Sub CreateTableDAO()
    Dim db As DAO.Database
    Dim tblNew As DAO.TableDef
    Dim fld As DAO.Field
    Dim prp As DAO.Property
    
    On Error GoTo ErrorHandler
    
    Set db = CurrentDb
    Set tblNew = db.CreateTableDef("Agents")
    
    Set fld = tblNew.CreateField("AgentID", dbText, 6)
    fld.ValidationRule = "Like 'A*'"
    fld.ValidationText = "Agent ID must begin with the letter 'A' " & _
    "and cannot contain more than 6 characters."
    tblNew.Fields.Append fld
    
    Set fld = tblNew.CreateField("Country", dbText)
    fld.DefaultValue = "USA"
    tblNew.Fields.Append fld
    
    Set fld = tblNew.CreateField("DateOfBirth", dbDate)
    fld.Required = True
    tblNew.Fields.Append fld
    db.TableDefs.Append tblNew
    
    ' Create Caption property and set its value
    ' add it to the collection of field properties
    Set prp = tblNew.Fields("DateOfBirth").CreateProperty("Caption")
    prp.Type = dbText
    prp.Value = "Date of Birth"
    fld.Properties.Append prp
    MsgBox fld.Properties("Caption").Value
    
    Set prp = tblNew.CreateProperty("Description")
    prp.Type = dbText
    prp.Value = "Sample table created with DAO code"
    tblNew.Properties.Append prp
    
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description
End Sub



'----------------------------------------------------------------
' Code on pages 256-257
'----------------------------------------------------------------
 
' make sure to set up a reference to
' the Microsoft ActiveX Data Objects 2.8 Library
' and ADO Ext. 2.8 for DDL and Security

Sub CreateTableADO()
   Dim conn As ADODB.Connection
   Dim cat As ADOX.Catalog
   Dim tbl As ADOX.Table

   Set conn = New ADODB.Connection
   conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
     "Data Source=C:\Acc07_ByExample\Chap11_Db2.mdb"

   Set cat = New ADOX.Catalog
   Set cat.ActiveConnection = conn

   Set tbl = New ADOX.Table
   tbl.Name = "tblAssets"

  cat.Tables.Append tbl

  With tbl.Columns
    .Append "SiteID", adVarWChar, 10
    .Append "Category", adSmallInt
    .Append "InstallDate", adDate
  End With

  Set cat = Nothing
  conn.Close
  Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 11-2
'----------------------------------------------------------------

' make sure to set up a reference to
' the Microsoft ActiveX Data Objects 2.8 Library

Sub Copy_Table()
    Dim conn As ADODB.Connection
    Dim strTable As String
    Dim strSQL As String
    
    On Error GoTo ErrorHandler
    
    strTable = "Customers"
    
    strSQL = "SELECT " & strTable & ".* INTO "
    strSQL = strSQL & strTable & "Copy "
    strSQL = strSQL & "FROM " & strTable
    
    Debug.Print strSQL
    
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    conn.Execute strSQL
    conn.Close
    Set conn = Nothing
    MsgBox "The " & strTable & " table was copied."
    Exit Sub
    
ErrorHandler:
    If Err.Number = -2147217900 Then
        conn.Execute "DROP Table " & strTable
        Resume
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If
End Sub


'----------------------------------------------------------------
' Hands-On 11-3
'----------------------------------------------------------------

Sub Delete_Table(strTblName As String)
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    
    On Error GoTo ErrorHandler
    
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn
    cat.Tables.Delete strTblName
    
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox "Table '" & strTblName & _
        "' cannot be deleted " & vbCrLf & _
        "because it does not exist."
    Resume Next
End Sub


'----------------------------------------------------------------
' Hands-On 11-4
'----------------------------------------------------------------

Sub Add_NewFields()
    Dim conn As ADODB.Connection
    Dim cat As New ADOX.Catalog
    Dim myTbl As New ADOX.Table
    
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn
    cat.Tables("CustomersCopy").Columns.Append _
        "MyNewField", adWChar, 15
    
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 11-5
'----------------------------------------------------------------

Sub Add_NewFieldsDAO()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim tblName As String
    
    tblName = "CustomersCopy"
    
    On Error GoTo ErrorHandler
    Set db = OpenDatabase("C:\Acc07_ByExample\Northwind.mdb")
    Set tdf = db.TableDefs(tblName)
    
    MsgBox "Number of fields in the table: " & _
        db.TableDefs(tblName).Fields.Count
    
    With tdf
        .Fields.Append .CreateField("NoOfMeetings", dbInteger)
        .Fields.Append .CreateField("Result", dbMemo)
    End With
    
    MsgBox "Number of fields in the table: " & _
        db.TableDefs(tblName).Fields.Count
    db.Close
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description
End Sub


'----------------------------------------------------------------
' Hands-On 11-6
'----------------------------------------------------------------

Sub Delete_Field()
    Dim conn As ADODB.Connection
    Dim cat As New ADOX.Catalog
    
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn
    cat.Tables("CustomersCopy").Columns.Delete "MyNewField"
    
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 11-7
'----------------------------------------------------------------

Sub DeleteFields_DAO()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim tblName As String
    
    tblName = "CustomersCopy"
    
    On Error GoTo ErrorHandler
    Set db = OpenDatabase("C:\Acc07_ByExample\Northwind.mdb")
    Set tdf = db.TableDefs(tblName)
    
    MsgBox "Number of fields in the table: " & _
        db.TableDefs(tblName).Fields.Count
    
    With tdf
        .Fields.Delete "NoOfMeetings"
        .Fields.Delete "Result"
    End With
    
    MsgBox "Number of fields in the table: " & _
        db.TableDefs(tblName).Fields.Count
    
    db.Close
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description
End Sub


'----------------------------------------------------------------
' Hands-On 11-8
'----------------------------------------------------------------

Sub List_TableProperties()
    Dim conn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim pr As ADOX.Property
    
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = conn
    
    Set tbl = cat.Tables("CustomersCopy")
    
    ' retrieve table properties
    For Each pr In tbl.Properties
        Debug.Print tbl.Name & ": " & _
        pr.Name & "= "; pr.Value
    Next
    
    Set cat = Nothing
    conn.Close
    Set conn = Nothing
End Sub

Sub List_TableProperties_DAO()
    Dim prp As DAO.Property
    Dim tdf As DAO.TableDef
    Dim db As DAO.Database
    
    Set db = CurrentDb
    Set tdf = db.TableDefs("Agents")
    
    For Each prp In tdf.Properties
        On Error Resume Next
        Debug.Print prp.Name & ": " & prp.Value
    Next
    MsgBox "Finished processing."
End Sub


'----------------------------------------------------------------
' Hands-On 11-9
'----------------------------------------------------------------

Sub List_FieldProperties()
    Dim cat As ADOX.Catalog
    Dim col As ADOX.Column
    Dim pr As ADOX.Property
    
    Set cat = New ADOX.Catalog
    Set cat.ActiveConnection = CurrentProject.Connection
    
    Set col = New ADOX.Column
    Set col = cat.Tables("Agents").Columns("AgentID")
    Debug.Print "Properties of the AgentID field " & _
        "(" & col.Properties.Count & ")"
    
    ' retrieve Field properties
    For Each pr In col.Properties
        Debug.Print pr.Name & "="; pr.Value
    Next
    Set cat = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 11-10
'----------------------------------------------------------------

Sub Link_JetTable()
    Dim cat As ADOX.Catalog
    Dim lnkTbl As ADOX.Table
    Dim strDb As String
    Dim strTable As String
    
    On Error GoTo ErrorHandler
    
    strDb = CurrentProject.Path & "\Northwind.mdb"
    strTable = "Customers"
    
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    Set lnkTbl = New ADOX.Table
    
    With lnkTbl
    ' Name the new Table and set its ParentCatalog property to the
    ' open Catalog to allow access to the Properties collection.
        .Name = strTable
        Set .ParentCatalog = cat
        ' Set the properties to create the link
        .Properties("Jet OLEDB:Create Link") = True
        .Properties("Jet OLEDB:Link Datasource") = strDb
        .Properties("Jet OLEDB:Remote Table Name") = strTable
    End With
    
    ' Append the table to the Tables collection
    cat.Tables.Append lnkTbl
    Set cat = Nothing
    
    MsgBox "The current database contains a linked " & _
        "table named " & strTable
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description
End Sub


'----------------------------------------------------------------
' Code on page 267
'----------------------------------------------------------------

Sub LinkDBaseTable_DAO()
    Dim db As DAO.Database
    Dim myTable As DAO.TableDef
    
    On Error GoTo err_LinkDbaseTable
    
    Set db = CurrentDb
    Set myTable = db.CreateTableDef("TableDBASE")
    
    myTable.Connect = "dBase 5.0;Database=C:\Acc07_ByExample"
    myTable.SourceTableName = "Customer.dbf"
    
    db.TableDefs.Append myTable
    db.TableDefs.Refresh
    
    MsgBox "dBase table has been successfully linked."
    Exit Sub
err_LinkDbaseTable:
    MsgBox Err.Number & ": " & Err.Description
End Sub


'----------------------------------------------------------------
' Hands-On 11-11
'----------------------------------------------------------------

Sub Link_ExcelSheet()
    Dim rst As ADODB.Recordset
    
    DoCmd.TransferSpreadsheet acLink, _
        acSpreadsheetTypeExcel12, _
        "mySheet", _
        CurrentProject.Path & "\Regions.xls", _
        -1, _
        "Regions!A1:B15"
    
    Set rst = New ADODB.Recordset
    With rst
        .ActiveConnection = CurrentProject.Connection
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Open "mySheet", , , , adCmdTable
    End With
    
    Do Until rst.EOF
        Debug.Print rst.Fields(0).Value, rst.Fields(1).Value
        rst.MoveNext
    Loop
    
    rst.Close
    Set rst = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 11-12
'----------------------------------------------------------------

Sub ListTbls()
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    
    Set cat = New ADOX.Catalog
    
    cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    For Each tbl In cat.Tables
        If tbl.Type <> "VIEW" And _
            tbl.Type <> "SYSTEM TABLE" And _
            tbl.Type <> "ACCESS TABLE" Then Debug.Print tbl.Name
    Next tbl
    Set cat = Nothing
    MsgBox "View the list of tables in the Immediate window."
End Sub


'----------------------------------------------------------------
' Hands-On 11-13
'----------------------------------------------------------------

Sub ListTbls2()
    ' This procedure lists database tables using the OpenSchema method
    Dim rst As ADODB.Recordset
    
    Set rst = CurrentProject.Connection.OpenSchema(adSchemaTables)
    
    Do Until rst.EOF
        Debug.Print rst.Fields("TABLE_TYPE") & " ->" _
            & rst.Fields("TABLE_NAME")
        rst.MoveNext
    Loop
End Sub


'----------------------------------------------------------------
' Hands-On 11-14
'----------------------------------------------------------------

Sub ListTblsAndFields()
    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim curTable As String
    Dim newTable As String
    Dim counter As Integer
    
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
        & "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    Set rst = conn.OpenSchema(adSchemaColumns)
    curTable = ""
    newTable = ""
    counter = 1
    
    Do Until rst.EOF
        curTable = rst!table_Name
        
        If (curTable <> newTable) Then
            newTable = rst!table_Name
            Debug.Print "Table: " & rst!table_Name
            counter = 1
        End If
        
        Debug.Print "Field" & counter & ": " & rst!Column_Name
        counter = counter + 1
        rst.MoveNext
    Loop
    
    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 11-15
'----------------------------------------------------------------

Sub ListDataTypes()
    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    
    Set conn = New ADODB.Connection
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
        & "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    Set rst = conn.OpenSchema(adSchemaProviderTypes)
    Do Until rst.EOF
        Debug.Print rst!Type_Name & vbTab _
            & "Size: " & rst!Column_Size
        rst.MoveNext
    Loop
    
    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 11-16
'----------------------------------------------------------------

Sub ChangeAutoNumber()
    Dim conn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim strSQL As String
    Dim beginNum As Integer
    Dim stepNum As Integer
    
    Set conn = New ADODB.Connection
    conn.Open "Provider = Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & CurrentProject.Path & _
        "\Northwind.mdb"
    
    Set rst = New ADODB.Recordset
    With rst
        .CursorType = adOpenKeyset
        .LockType = adLockReadOnly
        .Open "Shippers", conn
        .MoveLast
    End With
    
    beginNum = rst(0)
    rst.MovePrevious
    stepNum = beginNum - rst(0)
    MsgBox "Last Auto Number Value = " & beginNum & vbCr & _
        "Current Step Value = " & stepNum, vbInformation, _
        "AutoNumber"
    
    rst.Close
    conn.Close
    Set conn = Nothing
End Sub










