troubleshooting Question

Access Create Table in backend

Avatar of Murray Brown
Murray BrownFlag for United Kingdom of Great Britain and Northern Ireland asked on
DatabasesVBA
11 Comments2 Solutions36 ViewsLast Modified:
Hi

In Access I am using the following VBA code to add new columns in a linked table which is in another database.
What similar code would I use to rather create a new linked table?

Thanks



Sub Main
    Call Add_Column_to_Backend("t_Arms", "RegExpiryDate", "Date")
    Call Add_Column_to_Backend("t_Licence", "DriverExpiry", "Date")
   
End Sub


'==================== Add Backend Column =========================
Sub Add_Column_to_Backend(ByVal oTable As String, ByVal oColumn As String, ByVal oType As String)
   
    On Error Resume Next
   
    Dim strDbName As String 'Database name
    strDbName = GetLinkedDBName(oTable)
    Dim dbs As DAO.Database
    Dim tdf As DAO.TableDef
    Dim fld As DAO.field
    Dim blnFieldExists As Boolean
    ''Set dbs = CurrentDb()
   
    Set dbs = OpenDatabase(strDbName)
    Set tdf = dbs.TableDefs(oTable)
   
    For Each fld In tdf.Fields
        If fld.Name = oColumn Then
            blnFieldExists = True
            Exit For
        End If
    Next
    ''https://docs.microsoft.com/en-us/office/client-developer/access/desktop-database-reference/tabledef-createfield-method-dao
    If Not blnFieldExists Then
        If oType = "Date" Then
           Set fld = tdf.CreateField(oColumn, dbDate)
           fld.DefaultValue = "=Now()"
        ElseIf oType = "Text" Then
            Set fld = tdf.CreateField(oColumn, dbText)
        ElseIf oType = "Integer" Then
            Set fld = tdf.CreateField(oColumn, dbInteger)
        Else
            Set fld = tdf.CreateField(oColumn, dbText)
        End If
       
        ''
       
        tdf.Fields.Append fld
        MsgBox "New column & '" & oColumn & "' added to table '" & oTable & "'"
    End If
   
End Sub

Public Function GetLinkedDBName(TableName As String)
    Dim db As DAO.Database, Ret
    On Error GoTo DBNameErr
    Set db = CurrentDb()
    Ret = db.TableDefs(TableName).Connect
    GetLinkedDBName = Right(Ret, Len(Ret) - (InStr(1, Ret, "DATABASE=") + 8))
    Exit Function
DBNameErr:
    GetLinkedDBName = 0
End Function
'==================== Add Backend Column (End) =========================


'+++++++++++++++++++ Rename Backend Column +++++++++++++++++++++++
Public Sub RenameColumn(ByVal TableName As String, ByVal oldName As String, ByVal newName As String)
   
    On Error Resume Next
   
    Dim dbName As String
    dbName = GetLinkedDBName(TableName)
   
    Dim db As DAO.Database
    Set db = OpenDatabase(dbName)
   
    Dim tdf As DAO.TableDef
    Set tdf = db.TableDefs(TableName)
    If (ExistInCollection(oldName, tdf.Fields)) Then
        Dim field As DAO.field
        Set field = tdf.Fields(oldName)
       
        field.Name = newName
    End If
End Sub

Public Function ExistInCollection(ByVal key As String, ByRef col As Object) As Boolean
    On Error Resume Next
    ExistInCollection = ExistInCollectionByVal(key, col) Or ExistInCollectionByRef(key, col)
End Function

Private Function ExistInCollectionByVal(ByVal key As String, ByRef col As Object) As Boolean
On Error GoTo Error
    Dim item As Variant
    item = col(key)
    ExistInCollectionByVal = True
Exit Function
Error:
    ExistInCollectionByVal = False
End Function

Private Function ExistInCollectionByRef(ByVal key As String, ByRef col As Object) As Boolean
On Error GoTo Error
    Dim item As Variant
    Set item = col(key)
    ExistInCollectionByRef = True
Exit Function
Error:
    ExistInCollectionByRef = False
End Function
Join the community to see this answer!
Join our exclusive community to see this answer & millions of others.
Unlock 2 Answers and 11 Comments.
Join the Community
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 2 Answers and 11 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros