
'----------------------------------------------------------------
' Hands-On 12-1
'----------------------------------------------------------------

' 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 Create_PrimaryKey()
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim pKey As ADOX.Key
       
    On Error GoTo ErrorHandler
    
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    
    Set tbl = New ADOX.Table
    tbl.Name = "tblFilters"
    
    cat.Tables.Append tbl
    
    With tbl.Columns
       .Append "ID", adVarWChar, 10
       .Append "Description", adVarWChar, 255
       .Append "Type", adInteger
    End With
    
SetKey:
    Set pKey = New ADOX.Key
    With pKey
      .Name = "PrimaryKey"
      .Type = adKeyPrimary
    End With

    pKey.Columns.Append "ID"
    tbl.Keys.Append pKey
    
    Set cat = Nothing
    Exit Sub

ErrorHandler:
   If Err.Number = -2147217856 Then
      MsgBox "The " & tblName & " is open.", _
          vbCritical, "Please close the table"
   ElseIf Err.Number = -2147217857 Then
      MsgBox Err.Description
      Set tbl = cat.Tables(tbl.Name)
      Resume SetKey
   ElseIf Err.Number = -2147217767 Then
      tbl.Keys.Delete pKey.Name
      Resume
   Else
      MsgBox Err.Number & ": " & Err.Description
   End If
End Sub


'----------------------------------------------------------------
' Hands-On 12-2
'----------------------------------------------------------------


Sub Create_PrimaryKeyDAO()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim idx As DAO.Index
    
    Set db = OpenDatabase("C:\Acc07_ByExample\Chap11.accdb")
    Set tdf = db.TableDefs("Agents")
    
    ' create a Primary Key
    Set idx = tdf.CreateIndex("PrimaryKey")
    idx.Primary = True
    idx.Required = True
    idx.IgnoreNulls = False
    Set fld = idx.CreateField("AgentID", dbText)
    idx.Fields.Append fld
    
    ' add the index to the Indexes collection in the Agents table
    tdf.Indexes.Append idx
    db.Close
    Set db = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 12-3
'----------------------------------------------------------------

Sub Add_SingleFieldIndex()
   Dim cat As New ADOX.Catalog
   Dim myTbl As New ADOX.Table
   Dim myIdx As New ADOX.Index

   On Error GoTo ErrorHandler
   cat.ActiveConnection = CurrentProject.Connection
   Set myTbl = cat.Tables("tblFilters")

   With myIdx
      .Name = "idxDescription"
      .Unique = False
      .IndexNulls = adIndexNullsIgnore
      .Columns.Append "Description"
      .Columns(0).SortOrder = adSortAscending
   End With
   myTbl.Indexes.Append myIdx

   Set cat = Nothing
   Exit Sub

ErrorHandler:
   If Err.Number = -2147217856 Then
      MsgBox "The 'tblFilters' cannot be open.", vbCritical, _
          "Close the table"
   ElseIf Err.Number = -2147217868 Then
      myTbl.Indexes.Delete myIdx.Name
      Resume 0
   Else
      MsgBox Err.Number & ": " & Err.Description
   End If
End Sub


'----------------------------------------------------------------
' Hands-On 12-4
'----------------------------------------------------------------

Sub Add_MultiFieldIndex()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.Field
    Dim idx As DAO.Index
    
    Set db = OpenDatabase("C:\Acc07_ByExample\Northwind.mdb")
    Set tdf = db.TableDefs("Employees")
    
    Set idx = tdf.CreateIndex("Location")
    Set fld = idx.CreateField("City", dbText)
    idx.Fields.Append fld
    
    Set fld = idx.CreateField("Region", dbText)
    idx.Fields.Append fld
    tdf.Indexes.Append idx
    
    MsgBox "New index (Location) was created."
    db.Close
    Set db = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 12-5
'----------------------------------------------------------------

Sub List_Indexes()
   Dim conn As New ADODB.Connection
   Dim cat As New ADOX.Catalog
   Dim tbl As New ADOX.Table
   Dim idx As New ADOX.Index

   With conn
      .Provider = "Microsoft.Jet.OLEDB.4.0"
      .Open "Data Source=" & CurrentProject.Path & _
          "\Northwind.mdb"
   End With
   cat.ActiveConnection = conn
   Set tbl = cat.Tables("Employees")

   For Each idx In tbl.Indexes
      Debug.Print idx.Name
   Next idx

   conn.Close
   Set conn = Nothing
   MsgBox "Indexes are listed in the Immediate window."
End Sub


Sub List_IndexesDAO()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim idx As DAO.Index
    
    Set db = CurrentDb
    Set tdf = db.TableDefs("tblFilters")
    
    For Each idx In tdf.Indexes
        Debug.Print idx.Name
    Next

    ' show Immediate window
    SendKeys "^g"
    Set db = Nothing
End Sub


'----------------------------------------------------------------
' Hands-On 12-6
'----------------------------------------------------------------

Sub Delete_Indexes()
   ' This procedure deletes all but the primary key index
   ' from the Employees table in the Northwind database.
   ' Prior to running this procedure make a backup copy of
   ' the original Northwind.mdb database.

   Dim conn As New ADODB.Connection
   Dim cat As New ADOX.Catalog
   Dim tbl As New ADOX.Table
   Dim idx As New ADOX.Index
   Dim count As Integer

   With conn
      .Provider = "Microsoft.Jet.OLEDB.4.0"
      .Open "Data Source=" & CurrentProject.Path & _
          "\Northwind.mdb"
   End With

   cat.ActiveConnection = conn

Setup:
   Set tbl = cat.Tables("Employees")

   Debug.Print tbl.Indexes.count
   For Each idx In tbl.Indexes
       If idx.PrimaryKey <> True Then
         tbl.Indexes.Delete (idx.Name)
         GoTo Setup
       End If
   Next idx

   conn.Close
   Set conn = Nothing
   MsgBox "All Indexes but Primary Key were deleted."
End Sub


'----------------------------------------------------------------
' Hands-On 12-7
'----------------------------------------------------------------

Sub CreateTblRelation()
   Dim cat As New ADOX.Catalog
   Dim fKey As New ADOX.Key

   On Error GoTo ErrorHandle

   cat.ActiveConnection = CurrentProject.Connection

   With fKey
      .Name = "fkPubID"
      .Type = adKeyForeign
      .RelatedTable = "Publishers"
      .Columns.Append "PubID"
      .Columns("PubID").RelatedColumn = "PubID"
   End With
   cat.Tables("Titles").Keys.Append fKey
   MsgBox "Relationship was created."

   Set cat = Nothing
   Exit Sub

ErrorHandle:
   cat.Tables("Titles").Keys.Delete "fkPubID"
   Resume
End Sub

