'~~~~~~~~~~~~~~~~
'example showing how to add certain fields to a particular table
'~~~~~~~~~~~~~~~~

Sub testaddFieldToTable()
'  AddFieldToTable "test", "AutoID", dbLong, , "*AN*"
'  AddFieldToTable "test", "SomeID", dbLong, , "*Null*"
'  AddFieldToTable "test", "ImportLog", dbText, 255
   AddFieldToTable "test", "DateCreated", dbDate, , "*Now*"
  
End Sub

'~~~~~~~~~~~~~~~~
'example showing how to add the same fields
'to every user table in the database
'~~~~~~~~~~~~~~~~

'~~~~~~~~~~~~~~~~~~~~~~~~~~ RunAddFieldsToTable_Tracking
Sub RunAddFieldsToTable_Tracking()
   Dim tdf As DAO.TableDef
  
   Dim mCountDone As Integer _
      , mCountChecked As Integer

   For Each tdf In CurrentDb.TableDefs
      If Left(tdf.Name, 4) <> "Msys" Then
         Debug.Print
         Debug.Print tdf.Name & "...";
         mCountChecked = mCountChecked + 1
        
         If AddFieldToTable(tdf.Name, "EmpIDadd", dbLong _
            , , "*Null*", "employee who added record") Then
            mCountDone = mCountDone + 1
            Debug.Print "  EmpIDadd";
         End If
         If AddFieldToTable(tdf.Name, "EmpIDedit" _
            , dbLong, , "*Null*", "employee who last edited record") Then
            mCountDone = mCountDone + 1
            Debug.Print "  EmpIDedit";
         End If
         If AddFieldToTable(tdf.Name, "datAdd", dbDate _
            , , "*Now*", "date record was added") Then
            mCountDone = mCountDone + 1
            Debug.Print "  datAdd";
         End If
         If AddFieldToTable(tdf.Name, "datEdit", dbDate _
            , , , "date record was last edited") Then
            mCountDone = mCountDone + 1
            Debug.Print "  datEdit";
         End If
      End If
   Next tdf
   MsgBox mCountChecked & " tables checked" & vbCrLf & vbCrLf _
      & "Added " _
      & mCountDone & " tracking fields" _
      , , "Add Tracking Fields to Table Design"

Proc_Exit:
   On Error Resume Next
   'close and release object variables
   Set tdf = Nothing
   Exit Sub
  
Proc_Err:
   Select Case Err.Number
'      'Caption property not found
      Case 3270: Resume Next
   End Select
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   addTrackingFieldsToTable"

   'press F8 to step through code and debug
   'remove next line after debugged
   Stop:    Resume

   Resume Proc_Exit

End Sub

'~~~~~~~~~~~~~~~~
  
'put the following function in a general module:
'~~~~~~~~~~~~~~~~
  
'~~~~~~~~~~~~~~~~~~~~~~~~~~ AddFieldToTable
  
Function AddFieldToTable( _
   pTablename As String, _
   pFldname As String, _
   pDataType As Integer, _
   Optional pFieldSize As Integer, _
   Optional pDefaultValue As String = "", _
   Optional pDesc As String = "", _
   Optional pSkipMessage As Boolean = True) _
   As Boolean

   'written by Crystal
   'strive4peace2007 at yahoo.com
   'modified 8-28-07
    
   'PARAMETERS
   'pTablename --> name of table to modify structure of
   'pFldname --> name of field to create
   'pDataType --> dbText, dbLong, dbDate, etc
   'pFieldSize --> length for text fields
   'pDefaultValue --> *AN* = autonumber
   '         --> *Null* --> DefaultValue = Null
   '         --> *Now* --> DefaultValue = Now()
   '         --> otherwise whatever is specified
  
   'NEEDS Reference to
   'a Microsoft DAO Library
  
   On Error GoTo Proc_Err
  
   AddFieldToTable = False
  
   Dim db As DAO.Database, fld As DAO.Field

   'you could make this a passed parameter
   ' and open another database

   Set db = CurrentDb
  
   With db.TableDefs(pTablename)
  
      Select Case pDataType
        Case dbText
            'Text
            Set fld = .CreateField(pFldname, _
              pDataType, pFieldSize)
      
        Case Else
            'Long Integer, Date, etc
            Set fld = .CreateField(pFldname, pDataType)
          
      End Select
      
      If Len(pDefaultValue) > 0 Then
         Select Case pDefaultValue
         Case "*AN*"
            'Autonumber
            fld.Attributes = dbAutoIncrField
         Case "*Null*"
            'Null for DefaultValue
            fld.DefaultValue = "Null"
         Case "*Now*"
            'Now for DefaultValue
            fld.DefaultValue = "=Now()"
         Case Else
            'Now for DefaultValue
            fld.DefaultValue = "=" & pDefaultValue
         End Select
      End If
      
      
      If pDataType = dbText Then
         fld.AllowZeroLength = True
      End If
      
      .Fields.Append fld
      
      If Len(pDesc) > 0 Then
         On Error Resume Next
         fld.Properties("Description") = pDesc
         If Err > 0 Then
            fld.Properties.Append fld.CreateProperty("Description" _
               , dbText, pDesc)
         End If
         On Error GoTo Proc_Err
      End If
   End With
  
   db.TableDefs.Refresh
   DoEvents
  
   If Not pSkipMessage Then
     MsgBox "Added --> " & pFldname _
      & " to --> " & pTablename, , "Done"
   End If
  
   AddFieldToTable = True
  
Proc_Exit:
   On Error Resume Next
   If Not fld Is Nothing Then Set fld = Nothing
  
   'if db is external and you OPENed it,
   'you will need to close it too
   If Not db Is Nothing Then Set db = Nothing
  
   Exit Function
  
Proc_Err:
   'if the field is already there, ignore error
   If Err = 3191 Then Resume Proc_Exit
   'linked table
   If Err = 3057 Then Resume Proc_Exit
   MsgBox Err.Description, , _
     "ERROR " & Err.Number & "   AddFieldToTable"

   'press F8 to step through code and debug
   'remove or comment next line after debugged
   If IsAdmin Then Stop: Resume   'next line will be the one with the error
  
   Resume Proc_Exit
  
End Function

Option Compare Database

Public Sub CreatePKIndexes(strTableName As String, ParamArray varPKFields() As Variant)
Dim dbs As Database
Dim tdf As DAO.TableDef
Dim idx As DAO.Index
Dim idxFld As Variant
Dim varPKey As Variant
Set dbs = CurrentDb
On Error Resume Next
Set tdf = dbs.TableDefs(strTableName)

'Check if a Primary Key exists.
'If so, delete it.
varPKey = GetPrimaryKey(tdf)
If Not IsNull(varPKey) Then
    tdf.Indexes.Delete varPKey
End If

'Create a new primary key
Set idx = tdf.CreateIndex("PrimaryKey")
idx.Primary = True
idx.Required = True
idx.Unique = True

'Append the fields
For Each idxFld In varPKFields
    Set idxFld = idx.CreateField(idxFld)
    idx.Fields.Append idxFld
Next idxFld

'Append the index to the Indexes collection
tdf.Indexes.Append idx
'Refresh the Indexes collection
tdf.Indexes.Refresh

Set idx = Nothing
Set tdf = Nothing
Set dbs = Nothing

End Sub

Public Function GetPrimaryKey(tdf As DAO.TableDef) As Variant
'Determine if the specified primary key exists
Dim idx As Variant

For Each idx In tdf.Indexes
    If idx.Primary Then
        'If a Primary Key exists, return its name
        GetPrimaryKey = idx.Name
        GoTo GetPrimaryKey_Exit
    End If
Next idx

'If no Primary Key exists, return Null
GetPrimaryKey = Null
GetPrimaryKey_Exit:
End Function

   AddFieldToTable "Wave1Import", "SRC_CUST_ID", dbLong, , "*AN*"

Public Sub AddAutoNumPK()

    Dim strSQL As String

    strSQL = "ALTER TABLE tblYourTablename" & _
               " ADD COLUMN YourColumnName" & _
               " COUNTER CONSTRAINT PKName PRIMARY KEY"

    CurrentDb.Execute strSQL, dbFailOnError

End Sub

strSQL = "ALTER TABLE Wave1Import" & _
         " ADD CONSTRAINT PrimaryKey" & _
         " PRIMARY KEY (SRC_CUST_ID)"

For Each idxFld In varPKFields
   idx.Fields.Append idx.CreateField(idxFld)
Next idxFld

Public Sub DAO_CreateIndex(strTableName As String, _
                           strIndexName As String, _
                           strWithField As String, _
                           Optional blIsPrimary As Boolean, _
                           Optional blDescending As Boolean, _
                           Optional blIsUnique As Boolean)
'Create an index for the passed table, using the passed name and settings
    
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim idx As DAO.Index
    Dim fld As DAO.Field
    
    Set db = CurrentDb
    Set tdf = db.TableDefs(strTableName)
    
    With tdf
    
        'Instantiate the index
        Set idx = .CreateIndex(strIndexName)
    
        'Set the fields and properties of the index
        Set fld = idx.CreateField(strWithField)
        If blDescending Then fld.Attributes = dbDescending
        idx.Fields.Append fld
        idx.Primary = blIsPrimary
        If Not blIsPrimary Then idx.Unique = blIsUnique
    
        'Append the index to collection
        .Indexes.Append idx
    
    End With
    
End Sub
    
    
Public Sub ADOX_CreateIndex(strTableName As String, _
                           strIndexName As String, _
                           strWithField As String, _
                           Optional blIsPrimary As Boolean, _
                           Optional blDescending As Boolean, _
                           Optional blIsUnique As Boolean)
'Create an index for the passed table, using the passed name and settings
    
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim idx As ADOX.Index
    
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection.ConnectionString
    Set tbl = cat.Tables(strTableName)
    
    With tbl
    
        'Instantiate the index
        Set idx = New ADOX.Index
    
        'Set the Columns and properties of the index
        idx.Name = strIndexName
        idx.Columns.Append strWithField
        If blDescending Then
            idx.Columns(strWithField).SortOrder = adSortDescending
        End If
        idx.PrimaryKey = blIsPrimary
        If Not blIsPrimary Then idx.Unique = blIsUnique
    
        'Append the index to collection
        .Indexes.Append idx
    
    End With
    
End Sub