vba - 将驱动器链接映射到链接表的 UNC 链接

Question

我正在使用file dialog将表重新链接到后端，然后将链接表的映射驱动器连接字符串更改为UNC链接。但是我没有那么幸运，我遇到了以下问题：

1. 如果链接已经是链接，则下面的代码无法按预期工作UNC。我想重新链接到更新的位置。

2. sub可以uncLink使用循环吗？我尝试了一个For循环，但没有成功。

请看下面：

Private Sub Form_Load()
On Error Resume Next
Dim rs As DAO.Recordset: Set rs = CurrentDb.OpenRecordset("SELECT DonarArea FROM tblDonations")
If Err.Number <> 0 Then

MsgBox "Error Number: " & Err.Number & " " & Err.Description & " Please locate data file!", , "Data file not found"
Call AttachDataFile
End If
rs.Close
Set rs = Nothing
End Sub


Public Function AttachDataFile() As Boolean
Dim ofd As Object
Dim result As VbMsgBoxResult
Set ofd = Application.FileDialog(3)
ofd.AllowMultiSelect = False
ofd.Show
If ofd.SelectedItems.Count = 1 Then

    result = RelinkTablesToBackend(ofd.SelectedItems(1))
    If result = vbCancel Then
        AttachDataFile = False
    End If
    AttachDataFile = True
Else
    AttachDataFile = False
End If
End Function

Function RelinkTablesToBackend(BackEndPath As String) As VbMsgBoxResult

Dim tdf As TableDef
Dim db As database
Dim tdfRefresh As TableDef
Set db = CurrentDb

    For Each tdf In CurrentDb.TableDefs
    If tdf.Connect <> vbNullString Then
    On Error Resume Next
    db.TableDefs(tdf.Name).Connect = ";DATABASE=" & BackEndPath
    db.TableDefs(tdf.Name).RefreshLink
    If Err.Number <> 0 Then
    RelinkTablesToBackend = MsgBox(Err.Description, vbCritical + vbRetryCancel, "Error #:" & Err.Number)
               
    Exit Function
    End If

    End If
    Next

Set tdf = Nothing
Set db = Nothing
uncLink
End Function

Private Sub uncLink()
Dim strConn As String
Dim uncConn As String
Dim tdf As TableDef
strConn = CurrentDb.TableDefs("tblDonations").Connect
uncConn = GetUNCLateBound(strConn)

CurrentDb.TableDefs("tblDonations").Connect = ";DATABASE=" & uncConn
CurrentDb.TableDefs("tblDonations").RefreshLink
CurrentDb.TableDefs("tblNew").Connect = ";DATABASE=" & uncConn
CurrentDb.TableDefs("tblNew").RefreshLink
CurrentDb.TableDefs("tblDonatedItems").Connect = ";DATABASE=" & uncConn
CurrentDb.TableDefs("tblDonatedItems").RefreshLink
CurrentDb.TableDefs("tblWithAttachments").Connect = ";DATABASE=" & uncConn
CurrentDb.TableDefs("tblWithAttachments").RefreshLink


Set tdf = Nothing

End Sub

Function GetUNCLateBound(strMappedDrive As String) As String

Dim oFso  As Object
Dim strDrive As String
Dim strShare As String
Set oFso = CreateObject("Scripting.FileSystemObject")

strMappedDrive = Trim(Replace(CurrentDb.TableDefs("tblDonations").Connect, 
";DATABASE=", ""))
strDrive = oFso.GetDriveName(strMappedDrive)
strShare = oFso.Drives(strDrive & "\").ShareName

GetUNCLateBound = Replace(strMappedDrive, strDrive, strShare)
'MsgBox (strMappedDrive)
 Set oFso = Nothing

End Function

标签： vbams-access

Answer 1

以下对我有用：

Sub RelinkTablesToBackend(BackEndPath As String)
Dim tdf As TableDef
Dim db As Database
Dim tdfRefresh As TableDef
Dim strPath As String
Set db = CurrentDb
strPath = GetUNCLateBound(BackEndPath)
For Each tdf In CurrentDb.TableDefs
    If tdf.Connect <> vbNullString Then
        On Error Resume Next
        tdf.Connect = Replace(tdf.Connect, Replace(tdf.Connect, ";DATABASE=", ""), strPath)
        tdf.RefreshLink
        If Err.Number <> 0 Then
            RelinkTablesToBackend = MsgBox(Err.Description, vbCritical + vbRetryCancel, "Error #:" & Err.Number)
            Exit Function
        End If
    End If
Next
Set tdf = Nothing
Set db = Nothing
End Sub

Function GetUNCLateBound(strMappedDrive As String) As String
Dim oFso  As FileSystemObject
Dim strDrive As String
Dim strShare As String
Set oFso = CreateObject("Scripting.FileSystemObject")
GetUNCLateBound = strMappedDrive
If Left(strMappedDrive, 1) <> "C" Then
    strDrive = oFso.GetDriveName(strMappedDrive)
    strShare = oFso.Drives(strDrive).ShareName
    GetUNCLateBound = Replace(strMappedDrive, strDrive, strShare)
End If
Set oFso = Nothing
End Function