Link Tables

Link Tables

Private Const strTables As String = "Department,LineTable,Product,Shifts,Status,UOMTable,Users,WorkOrderDetails,WorkOrderHdr,ProductModel"

Private Sub cmdCreateLink_Click()
     Dim vTables
    Dim i As Integer
  
   
   If Len(Dir$(txtSource.Text)) > 0 And Len(Dir$(txtTarget.Text)) > 0 Then
        'Databases exist
    
        vTables = Split(strTables, ",")
        For i = 0 To UBound(vTables)
            'res = AccessLinkToTable(ThisWorkbookPath & "DB1\WOrderDb_be.mdb", ThisWorkbookPath & "WOrderDb.mdb", CStr(vTables(i)))
            LinkTable CStr(vTables(i)), txtSource.Text, txtTarget.Text
        Next
        MsgBox "Done linking database table from source."
        bOK = False: Me.Hide

    Else
        MsgBox "Invalid database path or database not found.", vbCritical
    End If
End Sub

Public Function AccessLinkToTable(sLinkFromDB As String, sLinkToDB As String, sLinkToTable As String, Optional sNewLinkTableName As String) As Boolean
    Dim CatDB As ADOX.Catalog
    Dim TblLink As ADOX.Table
    
    'On Error GoTo ErrFailed
    If Len(Dir$(sLinkFromDB)) > 0 And Len(Dir$(sLinkToDB)) > 0 Then
        'Databases exist
        Set CatDB = New ADOX.Catalog
        'Open a Catalog on database in which to create the link.
        CatDB.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & sLinkFromDB
        
        Set TblLink = New ADOX.Table
        With TblLink
            'Name the new Table
            If Len(sNewLinkTableName) Then
                .Name = sNewLinkTableName
            Else
                .Name = sLinkToTable
            End If
            
            'Set ParentCatalog property to the open Catalog.
            'This allows access to the Properties collection.
            Set .ParentCatalog = CatDB
            
            'Set the properties to create the link.
            .Properties("Jet OLEDB:Create Link") = True
            .Properties("Jet OLEDB:Link Datasource") = sLinkToDB
            .Properties("Jet OLEDB:Remote Table Name") = sLinkToTable
        End With
        
        On Error Resume Next
         CatDB.Tables.Delete TblLink
         On Error GoTo 0
        'Append the table to the Tables collection.
        CatDB.Tables.Append TblLink
        Set CatDB = Nothing
        'Set return as success
        AccessLinkToTable = True
    End If
'    Exit Function
'
'ErrFailed:
'    On Error GoTo 0
'    AccessLinkToTable = False
End Function

Public Sub LinkTable(psTable As String, psFromPath As String, _
  psToPath As String)

    Dim cnn As ADODB.Connection
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim sShortPath As String
    
    'get short path name of the source database
    sShortPath = Space(255)
    Call GetShortPathName(psFromPath, sShortPath, 255)
    sShortPath = Trim$(sShortPath)
    sShortPath = Left$(sShortPath, Len(sShortPath) - 1)
    
    'connect to the target database
    Set cnn = New ADODB.Connection
    With cnn
        '.Provider = "Provider=Microsoft.ACE.OLEDB.12.0"
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Data Source") = psToPath
        .Open
    End With
    
    Set cat = New ADOX.Catalog
    Set cat.ActiveConnection = cnn
        
    'link table
    Set tbl = New ADOX.Table
    With tbl
         .Name = psTable
         Set .ParentCatalog = cat
         .Properties("Jet OLEDB:Create Link") = True
         .Properties("Jet OLEDB:Link Datasource") = sShortPath
         .Properties("Jet OLEDB:Remote Table Name") = psTable
         
         On Error Resume Next
         cat.Tables.Delete psTable
         On Error GoTo 0
         
         cat.Tables.Append tbl
    End With
    Set tbl = Nothing
    
    'release references
    cnn.Close
    Set cnn = Nothing
    
    Set cat = Nothing
    
End Sub

---

Share This