如何在MS Access中使用VBA更改链接的共享点列表的地址

Question

在工作中，我们拥有使用共享点列表作为链接表的MS Access数据库，因为我们喜欢稳定性。 我们的共享点站点的地址将更改。 我想运行一个VBA子将表从旧地址更改为新地址。 这是我到目前为止的内容，但是有两个问题：

1. 它不会自动检测哪些表是共享点列表
2. 某些表“参与一种或多种关系”，并在删除时显示错误

我该如何做得更好？

  Sub ChangeSPTables()

    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim MBr As VbMsgBoxResult
    Dim N As String

    Set db = CurrentDb
    For Each tdf In db.TableDefs
        If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
            N = tdf.Name
            MBr = MsgBox("Delete and relink " & N & "?", vbYesNoCancel)
            If MBr = vbYes Then
                DoCmd.DeleteObject acTable, N
                DoCmd.TransferSharePointList acLinkSharePointList, "https://redacted", N
            End If
        End If
    Next
    Set tdf = Nothing
    Set db = Nothing

    End Sub

Answer 1

相关表不能删除，但可以删除。 添加表还会添加相关表，因此我在重复添加时遇到了麻烦。 我存储了所有要删除的名称，然后先重新添加（如果尚不存在）。 共享点地址是连接字符串的一部分，因此我能够像这样筛选所需的表。

编辑：使用DoCmd.TransferSharePointList可以导致带有查找列的列表以只读形式进入。 对于此类列表，请在运行后手动删除并添加它们。

Sub ChangeSPTables()
'Step through all table definitions and check if the old sharepoint address appears in the connection string
'If so, stores the name of the table, deletes all such tables, and re-adds them from the new sharepoint address
'The list is used because sometimes other tables are brought in automatically as relationships and I don't
'want extra copies or instances where the table has a 1 on the end of the name
'Will not work on things that have been renamed since they were brought in from sharepoint
'You should probably only run this on a copy of the database for saftey's sake

Dim db As dao.Database
Dim tdf As dao.TableDef
Dim MBr As VbMsgBoxResult
Dim i As Long: i = 1
Dim ListNames(1 To 20) As String 'Assumed to be 20 or less

'The old and new sharepoint addresses
Dim OldSP As String
Dim NewSP As String
OldSP = "https://old"
NewSP = "https://new"

Set db = CurrentDb
For Each tdf In db.TableDefs
    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") And InStr(1, tdf.Connect, OldSP) > 0 Then
        ListNames(i) = tdf.Name
        i = i + 1
        Debug.Print tdf.Name 'For review of which tables were redone
        db.Execute "drop table [" & tdf.Name & "]", dbFailOnError 'drop table avoids problems with relationships between tables
    End If
Next

i = 1
Do Until ListNames(i) = ""
    If IsNull(DLookup("Name", "MSysObjects", "Name='" & ListNames(i) & "'")) Then 'Some things get re-added by relationship
        DoCmd.TransferSharePointList acLinkSharePointList, NewSP, ListNames(i)
    End If
    i = i + 1
Loop

'Hide the sharepoint tables
For Each tdf In db.TableDefs
    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") And InStr(1, tdf.Connect, NewSP) > 0 Then
        Application.SetHiddenAttribute acTable, tdf.Name, True
    End If
Next

Set tdf = Nothing
Set db = Nothing
End Sub