通过vba链接表

Question

我正在为我在美国的同事（我位于英国的同事）完成一项任务。但是，我的数据库应用程序通过网络使用链接表到微软访问数据库文件，该文件在存储客户信息时已经过加密。

美国方面没有同事具有类似的技能，可以通过VBA对数据库位置进行任何更改。我已经看到了连接到SQL数据库的各种方法，如下面的microsoft链接所示。但是，为了使某人更容易改变数据库的位置。

是否可以修改下面的代码，以便查看一个文本文件，该文件将包含数据库后端的位置（例如C：\ users \ public \ test1），然后将表格链接到前面结束。

我已经找到了下面的代码，但它错误地说＆＃34;对象msysaccessstorage已经存在＆＃34;。它出错了＆＃34; CurrentDb.TableDefs.Append tdf＆＃34;。

Option Explicit
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim mypass As String
Dim mypath As String
Dim myDb As String
Dim TableName As String


Function connectme()

mypass = "test1"
mypath = "C:\Users\Test1\Desktop\"
myDb = "EM1.accdb"

 ' Delete links so there won't be any duplicates
For Each tdf In CurrentDb.TableDefs
If Left(tdf.Name, 4) <> "MSys" And Left(tdf.Name, 15) <> "tblReportsState" And _
(tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
CurrentDb.TableDefs.Delete tdf.Name
End If
Next tdf
Set tdf = Nothing

 ' Setup Links
Set dbs = OpenDatabase(mypath & myDb, False, False, "MS Access;PWD=" & mypass)

For Each tdf In dbs.TableDefs
If Left(tdf.Name, 4) <> "msys" Then
TableName = tdf.Name
Set tdf = CurrentDb.CreateTableDef(TableName)
tdf.Connect = ";PWD=" & mypass & ";Database=" + mypath + myDb
tdf.SourceTableName = TableName
CurrentDb.TableDefs.Append tdf
End If
Next

End Function

Answer 1

您可能会收到此错误，因为Access＆＃39; Tabledefs列表并不总是立即反映您所做的更改，即删除。在任何CurrentDB.TableDefs.Refresh和/或.Append之后，您可以使用.Delete 刷新它，但这需要时间，并且考虑到刷新的链接表需要大量数据每个时间，时间是你可能无法承受的。

最好检查TableDefs预先存在的链接并刷新它们，而不是删除并重新创建它们，因为删除它们也会删除任何格式，例如刷新将留下的列宽和字段格式不变。

如果您的表格需要刷新其链接，请更改.Connect属性，然后使用CurrentDB.TableDefs(TableName).RefreshLink

当源表不再存在时，您应该只使用CurrentDb.TableDefs.Delete tdf.Name。

我自己使用与此类似的方法，但是我还存储了上次链接表刷新的日期和时间，并且仅刷新那些在此之后修改了其架构的表。有一百个或更多的表链接和每个表2+秒来刷新链接，我需要一直保存。

修改

以下代码是我用来执行将MS Access连接到SQL Server的类似任务的代码。

免责声明：以下代码按原样提供，无法正常运行以获取纯Access前端/后端情况。 必须根据您的需要进行修改。

Public Sub RefreshLinkedTables()
    Dim adoConn As ADODB.Connection
    Dim arSQLObjects As ADODB.Recordset
    Dim CreateLink As Boolean, UpdateLink As Boolean, Found As Boolean
    Dim dWS As DAO.Workspace
    Dim dDB As DAO.Database
    Dim drSQLSchemas As DAO.Recordset, drSysVars As DAO.Recordset, drMSO As DAO.Recordset
    Dim dTDef As DAO.TableDef
    Dim ObjectTime As Date
    Dim sTStart As Double, sTEnd As Double, TStart As Double, TEnd As Double
    Dim CtrA As Long, ErrNo As Long
    Dim DescStr As String, SQLStr As String, ConnStr As String
    Dim SQLObjects() As String

    sTStart = PerfTimer()
    Set dWS = DBEngine.Workspaces(0)
    Set dDB = dWS.Databases(0)
    Set drSysVars = dDB.OpenRecordset("tbl_SysVars", dbOpenDynaset)
    If drSysVars.RecordCount = 0 Then Exit Sub
    AppendTxtMain "Refreshing Links to """ & drSysVars![ServerName] & """: """ & drSysVars![Database] & """ at " & Format(Now, "hh:mm:ss AMPM"), True
    Set adoConn = SQLConnection()
    Set arSQLObjects = New ADODB.Recordset
    SQLStr = "SELECT sys.schemas.name AS [Schema], sys.objects.*, sys.schemas.name + '.' + sys.objects.name AS SOName " & _
             "FROM sys.objects INNER JOIN sys.schemas ON sys.objects.schema_id = sys.schemas.schema_id " & _
             "WHERE (sys.objects.type IN ('U', 'V')) AND (sys.objects.is_ms_shipped = 0) " & _
             "ORDER BY SOName"
    ObjectTime = Now()
    arSQLObjects.Open SQLStr, adoConn, adOpenStatic, adLockReadOnly, adCmdText
    Set drSQLSchemas = dWS.Databases(0).OpenRecordset("SELECT * FROM USys_tbl_SQLSchemas WHERE LinkObjects = True", dbOpenDynaset)
    Set drMSO = dWS.Databases(0).OpenRecordset("SELECT Name FROM MSysObjects WHERE Type In(1,4,6) ORDER BY Name", dbOpenSnapshot)
    ReDim SQLObjects(0 To arSQLObjects.RecordCount - 1)
    With arSQLObjects
        drMSO.MoveFirst
        If Not .EOF Then
            .MoveLast
            .MoveFirst
        End If
        prgProgress.Max = .RecordCount
        prgProgress = 0
        CtrA = 0
        ConnStr = "DRIVER={SQL Server Native Client 10.0};SERVER=" & drSysVars![ServerName] & ";DATABASE=" & drSysVars![Database]
        If Nz(drSysVars![UserName]) = "" Then
            ConnStr = ConnStr & ";Trusted_Connection=YES"
        Else
            ConnStr = ConnStr & ";Uid=" & drSysVars![UserName] & ";Pwd=" & drSysVars![Password] & ";"
        End If
        Do Until .EOF
            TStart = PerfTimer
            SQLObjects(CtrA) = arSQLObjects![Schema] & "_" & arSQLObjects![Name]
            AppendTxtMain ![SOName] & " (" & ![modify_date] & "): ", True
            drSQLSchemas.FindFirst "[SchemaID] = " & ![schema_id]
            If Not drSQLSchemas.NoMatch Then
                UpdateLink = False
                CreateLink = False
                drMSO.FindFirst "Name=""" & drSQLSchemas![SchemaName] & "_" & arSQLObjects![Name] & """"
                If drMSO.NoMatch Then
                    CreateLink = True
                    AppendTxtMain "Adding Link... "
                    Set dTDef = dDB.CreateTableDef(arSQLObjects![Schema] & "_" & arSQLObjects![Name], dbAttachSavePWD, ![SOName], "ODBC;" & ConnStr)
                    dDB.TableDefs.Append dTDef
                    dDB.TableDefs(dTDef.Name).Properties.Append dTDef.CreateProperty("Description", dbText, "«Autolink»")
                ElseIf ![modify_date] >= Nz(drSysVars![SchemaUpdated], #1/1/1900#) Or RegexMatches(dDB.TableDefs(arSQLObjects![Schema] & "_" & arSQLObjects![Name]).Connect, "SERVER=(.+?);")(0).SubMatches(0) <> drSysVars![ServerName] _
                       Or (dDB.TableDefs(arSQLObjects![Schema] & "_" & arSQLObjects![Name]).Attributes And dbAttachSavePWD) <> dbAttachSavePWD Then
                    UpdateLink = True
                    AppendTxtMain "Refreshing Link... "
                    With dDB.TableDefs(arSQLObjects![Schema] & "_" & arSQLObjects![Name])
                        .Attributes = dbAttachSavePWD
                        .Connect = "ODBC;" & ConnStr
                        .RefreshLink
                    End With
                End If
            End If
            TEnd = PerfTimer()
            AppendTxtMain SplitTime(TEnd - TStart, 7, "s")
            .MoveNext
            prgProgress = prgProgress + 1
            CtrA = CtrA + 1
        Loop
    End With
    prgProgress = 0
    prgProgress.Max = dDB.TableDefs.Count
    DoEvents
    dDB.TableDefs.Refresh
    TStart = PerfTimer()
    AppendTxtMain "Deleting obsolete linked tables, started " & Now() & "...", True
    For Each dTDef In dDB.TableDefs
        If dTDef.Connect <> "" Then ' Is a linked table...
            On Error Resume Next
            DescStr = dTDef.Properties("Description")
            ErrNo = Err.Number
            On Error GoTo 0
            Select Case ErrNo
                Case 3270   ' Property does not exist
                    ' Do nothing.
                Case 0      ' Has a Description.
                    If RegEx(DescStr, "«Autolink»") Then    ' Description includes "«Autolink»"
                        Found = False
                        For CtrA = 0 To UBound(SQLObjects)
                            If SQLObjects(CtrA) = dTDef.Name Then
                                Found = True
                                Exit For
                            End If
                        Next
                        If Not Found Then   ' Delete if not in arSQLObjects
                            AppendTxtMain "Deleting """ & dTDef.Name & """", True
                            dDB.TableDefs.Delete dTDef.Name
                        End If
                    End If
            End Select
        End If
        prgProgress = prgProgress + 1
    Next
    TEnd = PerfTimer()
    AppendTxtMain "Completed at " & Now() & " in " & SplitTime(TEnd - TStart, 7, "s"), True
    drSysVars.Edit
    drSysVars![SchemaUpdated] = ObjectTime
    drSysVars.Update
    drSQLSchemas.Close
    dDB.TableDefs.Refresh
    Application.RefreshDatabaseWindow
    Set drSQLSchemas = Nothing
    arSQLObjects.Close
    Set arSQLObjects = Nothing
    adoConn.Close
    Set adoConn = Nothing
    drSysVars.Close
    Set drSysVars = Nothing
    drMSO.Close
    Set drMSO = Nothing
    dDB.Close
    Set dDB = Nothing
    dWS.Close
    Set dWS = Nothing
    prgProgress = 0
End Sub