Linking Tables using ADOX

[ineuw]

I am in the process of converting DAO code to ADO. I have written the procedure listed below which doesn't work. It links the 1st table of the Back End database and fails when linking the 2nd table in the list.

I would greatly appreciate if anyone with knowledge of ADOX could help me and show where I went astray.

Many thanks in advance. . . . and here is the procedure!

Private Function fnCreateNewLinks(ByVal strLBackEndDB As String)
On Error GoTo ErrorHandler
bytCancel = 0

Dim adoBackEndConn As New ADODB.Connection
Dim adoBackEndCat As New ADOX.Catalog
Dim adoBackEndTable As New ADOX.Table

Dim adoFrontEndConn As New ADODB.Connection
Dim adoFrontEndCat As New ADOX.Catalog
Dim adoFrontEndTable As New ADOX.Table

adoBackEndConn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data BackEnd=" & strLBackEndDB & ";"
adoFrontEndConn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data BackEnd=" & Application.CurrentDb.Name & ";"

adoBackEndCat.ActiveConnection = adoBackEndConn
adoFrontEndCat.ActiveConnection = adoFrontEndConn

Set adoBackEndTable.ParentCatalog = adoBackEndCat
Set adoFrontEndTable.ParentCatalog = adoFrontEndCat

For Each adoBackEndTable In adoBackEndCat.Tables

With adoBackEndTable

If Left$(adoBackEndTable.Name, 4) = "MSys" Then GoTo NextTable

With adoFrontEndTable
.Name = adoBackEndTable.Name
.Properties("Jet OLEDB:Link DataBackEnd") = strLBackEndDB
.Properties("Jet OLEDB:Remote Table Name") = adoBackEndTable.Name
.Properties("Jet OLEDB:Create Link") = True
End With

End With

adoFrontEndCat.Tables.Append adoFrontEndTable

NextTable:

Next adoBackEndTable

ResumeErr:

Set adoBackEndConn = Nothing: Set adoBackEndCat = Nothing: Set adoBackEndTable = Nothing
Set adoFrontEndConn = Nothing: Set adoFrontEndCat = Nothing: Set adoFrontEndTable = Nothing

Exit Function

ErrorHandler:

MsgBox Err.Number & vbCrLf & Err.Description, Application.CurrentObjectName
Err.Clear: Resume ResumeErr

End Function