Option Compare Database

Function RefurbishLinkTable(strDBName As String)
    '本函数建立由strDBName指定的数据库中所有表的链接表
    On Error Resume Next
    Dim strTableName As String
    strTableName = GetTableNameList(strDBName) '获取所有表名。格式为：表名1;表名2;...
   
    Dim strA() As String
    strA = Split(strTableName, ";") '将strTableName转化为数组
    Dim i As Integer
   
    For i = 0 To UBound(strA) '循环建立链接表，链接表前缀为“Link_”
        DoCmd.DeleteObject acTable, "Link_" & strA(i)
        DoCmd.TransferDatabase acLink, "microsoft Access", strDBName, acTable, strA(i), "Link_" & strA(i)
    Next
End Function

Function GetTableNameList(strDBName As String) As String
'本函数获取strDBName指定的数据库中的所有表名
'strDBName为数据库的完整路径及文件名。
'以字符串形式返回结果
'格式为： 表名1;表名2;...
    Dim CN As ADODB.Connection
    Set CN = New ADODB.Connection
    CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBName
    Set RS = CN.OpenSchema(adSchemaTables)
    Dim TableNameList As String
    TableNameList = ""
    Do Until RS.EOF
        If RS("TABLE_TYPE") = "TABLE" Then
            TableNameList = TableNameList & RS("TABLE_NAME") & ";"
        End If
        RS.MoveNext
    Loop
    RS.Close
    GetTableNameList = TableNameList
End Function