（转）如何使用ADOX/DAO刷新/更新/删除并重定义链接表

早起旺财

墨衍会员 · AI 创作全网分发码龄24年

关注

转载最新推荐文章于 2020-06-22 09:17:22 发布 1k 阅读 AI 写同款· GEO 优化 ›

学习提速专享！AI工具全家桶免费用限时购周边加赠Coding Plan Lite，解锁20+主流AI工具，写代码、查资料快人一步！阅读详情

方法一：

如何使用ADOX刷新链接表

Public Sub NewLinkedExternalTableMdb()
　　
　　' strTargetDB: 被链接的数据库路径名
　　' strProviderString: 连接字符串
　　' strSourceTbl: 被链接的源表名称
　　' strLinkTblName: 要重设链接的链接表的名称
　　Dim strTargetDB() As String
　　Dim strProviderString() As String
　　Dim strSourceTbl() As String
　　Dim strLinkTblName() As String
　　
　　Dim catDB　 As ADOX.Catalog
　　Dim tblLink As ADOX.Table
　　Dim tmpLink As ADOX.Table
　　
　　Dim i As Integer
　　Dim j As Integer

　　Set catDB = New ADOX.Catalog
　　catDB.ActiveConnection = CurrentProject.Connection
　　
　　i = catDB.Tables.Count
　　
　　ReDim strTargetDB(i)
　　ReDim strProviderString(i)
　　ReDim strSourceTbl(i)
　　ReDim strLinkTblName(i)
　　
　　i = 1
　　
　　For Each tmpLink In catDB.Tables
　　　　
　　　　If tmpLink.Properties("Jet OLEDB:Create Link") Then
　　　　　　If Trim(tmpLink.Properties("Jet OLEDB:Remote Table Name")) <> "" Then
　　　　　　
　　　　　　　　Debug.Print tmpLink.Name & " |　" & tmpLink.Properties("Jet OLEDB:Remote Table Name")
　　　　　　　　
　　　　　　　　strLinkTblName(i) = tmpLink.Name
　　　　　　　　strTargetDB(i) = tmpLink.Properties("Jet OLEDB:Link Datasource")
　　　　　　　　strProviderString(i) = tmpLink.Properties("Jet OLEDB:Link Provider String")
　　　　　　　　strSourceTbl(i) = tmpLink.Properties("Jet OLEDB:Remote Table Name")
　　　　　　　　
　　　　　　　　Do While InStr(1, strTargetDB(i), "/") <> 0
　　　　　　　　　　strTargetDB(i) = Mid(strTargetDB(i), InStr(1, strTargetDB(i), "/") + 1, Len(strTargetDB(i)))
　　　　　　　　Loop
　　　　　　　　
　　　　　　　　strTargetDB(i) = CurrentProject.Path & "/" & strTargetDB(i)
　　　　　　　　
　　　　　　　　i = i + 1
　　　　　　End If
　　　　End If
　　
　　Next
　　
　　j = i - 1
　　
　　For i = 1 To j
　　　　catDB.Tables.Delete strLinkTblName(i)
　　　　　　
　　　　Set tblLink = New ADOX.Table
　　　　　　
　　　　With tblLink
　　　　　　.Name = strLinkTblName(i)
　　　　　　Set .ParentCatalog = catDB
　　　　　　　　
　　　　　　.Properties("Jet OLEDB:Create Link") = True
　　　　　　.Properties("Jet OLEDB:Link Datasource") = strTargetDB(i)
　　　　　　.Properties("Jet OLEDB:Link Provider String") = strProviderString(i)
　　　　　　.Properties("Jet OLEDB:Remote Table Name") = strSourceTbl(i)
　　　　End With
　　　　　　　　
　　　　catDB.Tables.Append tblLink
　　　　Set tblLink = Nothing
　　Next
　　Set catDB = Nothing
　　'DoCmd.TransferDatabase acLink, "microsoft Access", "C:/a.mdb", acTable, "表1", "表x1"
　　'也可以达到链接表的效果
End Sub

方法二：

-----------------------------------------------------------
以前还用了个DAO的，放一起吧，记得引用DAO
-----------------------------------------------------------

Public Function RefreshLinks(strFileName As String) As Boolean
    Dim dbsOrders As DAO.Database
    Dim tdf As DAO.TableDef
    Dim intCount As Integer
On Error GoTo ErrorHandler
    Set dbsOrders = CurrentDb
    For intCount = 0 To dbsOrders.TableDefs.Count - 1

        Set tdf = dbsOrders.TableDefs(intCount)
        Debug.Print tdf.name & "-----找到表"
        If tdf.name = "~TMPCLP192931" Or tdf.name = "ke_hu1" Or tdf.name = "dbo_票点" Then
            Debug.Print "Ke_hu表因为是DBASE 5类型无法更新因此跳过"
        Else
            If Len(tdf.Connect) > 0 Then
                tdf.Connect = ";DATABASE=" & strFileName
                Err.Number = 0
                On Error Resume Next
                tdf.RefreshLink         ' Relink the table.
                If Err.Number <> 0 Then
                    RefreshLinks = False
                    Exit Function
                End If
            End If
        End If
    Next intCount
    RefreshLinks = True        ' Relinking complete.
    Exit Function
ErrorHandler:
    MsgBox "Error#:  " & Err.Number & vbCrLf & Err.Description
    RefreshLinks = False
End Function

方法三：

【摘】重新定位链接表二步走

[ kevindeng 2003年7月20日，阅读人数193人 ]

尽管Accxp网上有很多关于定位链接表的贴子，但还是有很多的朋友询问这方面的问题。应letter网友的提议，结合Alex总版主的重新定位链接表文件源码，现将这方面的具体操作介绍如下：

假设前台数据库文件名为frontBase.mdb
后台数据库文件名为backData.mdb
frontBase当中有链接表tbl1, tbl2, tbl3, …，链接到backData.mdb中

首先我们要在前台数据库文件的启动窗体加载事件中判断链接是否正确，方法是打开任意一个链接表，假设为tbl1，代码如下：

Public Function CheckLinks() As Boolean
' 检查到后台数据库的链接；如果链接存在且正确的话，返回 True 。　　
　　Dim dbs As Database, rst As DAO.Recordset　　
　　Set dbs = CurrentDb()
　　' 打开链接表查看表链接信息是否正确。
　　On Error Resume Next
　　Set rst = dbs.OpenRecordset(“tbl1”)
　　rst.Close
　　' 如果没有错误，返回 True 。
　　If Err = 0 Then
　　　　CheckLinks = True
　　Else
　　　　CheckLinks = False
　　End If　　
End Function

启动窗体的加载事件：

Private Sub FORM_Load()
If CheckLinks = False then
Docmd.OpenFORM “frmConnect”
End If
End Sub

frmConnect 连接窗体如下图

接下来的事情就是如何刷新链接表了。
上面的窗体右边的按钮是用用来调用API打开文件对话框，具体代码如下：

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean

Type OPENFILENAME
　　lStructSize As Long
　　hwndOwner As Long
　　hInstance As Long
　　lpstrFilter As String
　　lpstrCustomFilter As String
　　nMaxCustFilter As Long
　　nFilterIndex As Long
　　lpstrFile As String
　　nMaxFile As Long
　　lpstrFileTitle As String
　　nMaxFileTitle As Long
　　lpstrInitialDir As String
　　lpstrTitle As String
　　flags As Long
　　nFileOffset As Integer
　　nFileExtension As Integer
　　lpstrDefExt As String
　　lCustData As Long
　　lpfnHook As Long
　　lpTemplateName As String
End Type

Private Sub FileOpen_Click()
　 Dim ofn As OPENFILENAME
　 Dim rtn As String

　 ofn.lStructSize = Len(ofn)
　 ofn.hwndOwner = Me.hwnd
　
　 ofn.lpstrFilter = "数据库文件 (*.mdb)" & vbNullChar & "*.mdb"
　 ofn.lpstrFile = Space(254)
　 ofn.nMaxFile = 255
　 ofn.lpstrFileTitle = Space(254)
　 ofn.nMaxFileTitle = 255
　 ofn.lpstrInitialDir = CurrentProject.Path
　 ofn.lpstrTitle = "后台数据文件为"
　 ofn.flags = 6148

　 rtn = GetOpenFileName(ofn)
　
　 FileName.SetFocus
　 If rtn = True Then
　　　 FileName.Text = ofn.lpstrFile
　　　 FileName.Text = FileName.Text
　　　 OK.Enabled = True
　 Else
　　　 FileName.Text = ""
　 End If
End Sub

连接按钮刷新链接表，代码如下：

Private Sub OK_Click()
Dim tabDef As TableDef
For Each tabDef In CurrentDb.TableDefs
If Len(tabDef.Connect) > 0 Then
tabDef.Connect = ";DATABASE=" & Me.FileName.Text & ";PWD=" + 后台数据库密码
tabDef.RefreshLink
End If
Next
MsgBox "连接成功！"
DoCmd.Close acFORM, Me.Name
End Sub

其实很简单只有两步，判断链接是否正确和刷新链接表。

方法四：

直接用TransferDatabase 来完成

Function OnStart()
    CheckLink "Switchboard Items;tblInExMoney;tblInExType;tblMoneyType;tblTransferMoney;tblType", "收支平衡表.mdb"
End Function
Function CheckLink(ByVal strTableName As String, strDBName As String)
    On Error Resume Next
    Dim strA() As String
    strA = Split(strTableName, ";")
    Dim i As Integer

    For i = 0 To UBound(strA)
        DoCmd.DeleteObject acTable, strA(i)
        DoCmd.TransferDatabase acLink, "microsoft Access", CurrentProject.Path & "/" & strDBName, acTable, strA(i), strA(i)
    Next

End Function

收录于