This will create a link to any data table in a secured SQL Db to an access db, or if it is already linked, refresh the link string.
Function ConnectSQLDatabaseToAccess()
Dim stconnect As String
Dim cnn As New ADODB.Connection
Dim objSQLDataBaseCat As ADOX.Catalog
Dim objLocalAccesDBCat As ADOX.Catalog
Dim objAccessLinkedTbl As ADOX.Table
Dim objSQLTbl As ADOX.Table
'*******>>> SQL SERVER CAT ->>>> replace hard code with parameters or table lookup based on
'*** a form
Set objSQLDataBaseCat = New ADOX.Catalog
cnn.Open "Driver={SQL Server};" & _
"Server=SomeSQLServer;" & _
"Database=SomeDatabase;" & _
"Uid=xxx;" & _
"Pwd=yyyyyy;"
Set objSQLDataBaseCat.ActiveConnection = cnn
'****************************************
'*******>>> LOCAL ACCESS CAT
Set objLocalAccesDBCat = New ADOX.Catalog
'for local connections, for remote connections set a connection string here
objLocalAccesDBCat.ActiveConnection = CurrentProject.Connection
'***************************
For Each objSQLTbl In objSQLDataBaseCat.Tables
If objSQLTbl.Type = "TABLE" Then
'check if it's linked
If IsNull(DLookup("ForeignName", "MSysObjects", "ForeignName ='" + "dbo." + objSQLTbl.Name + "' AND MSysObjects.Type=4")) Then
'not there, link it
Set objAccessLinkedTbl = New ADOX.Table
objAccessLinkedTbl.Name = objSQLTbl.Name
Set objAccessLinkedTbl.ParentCatalog = objLocalAccesDBCat
With objAccessLinkedTbl
.Properties("Jet OLEDB:Create Link") = True
.Properties("Jet OLEDB:Link Provider String") = stconnect
.Properties("Jet OLEDB:Cache Link Name/Password") = True
.Properties("Jet OLEDB:Remote Table Name") = objSQLTbl.Name
End With
objLocalAccesDBCat.Tables.Append objAccessLinkedTbl
Set objAccessLinkedTbl = Nothing
Else
'refresh
Set objAccessLinkedTbl = New ADOX.Table
Set objAccessLinkedTbl.ParentCatalog = objLocalAccesDBCat
objAccessLinkedTbl.Name = DLookup("Name", "MSysObjects", "ForeignName ='" + "dbo." + objSQLTbl.Name + "' AND MSysObjects.Type=4")
With objAccessLinkedTbl
.Properties("Jet OLEDB:Link Provider String") = stconnect
End With
objLocalAccesDBCat.Tables.Refresh
Set objAccessLinkedTbl = Nothing
End If
End If
Next
Set objSQLDataBaseCat = Nothing
End Function