الاحتفاظ بالجداول المرتبطة لقواعد بيانات Access في نفس المجلد عند تغيير المجلد
-
22-08-2019 - |
سؤال
لدي قاعدتي بيانات Access تشتركان في الجداول المرتبطة.يتم نشرها معًا في دليل ويمكن الوصول إليها عبر التعليمات البرمجية في نموذج Word.
كيف يمكنني التأكد من الحفاظ على الروابط عند نسخ قاعدتي البيانات (معًا) إلى مجلد مختلف؟نظرًا لأنني لا "أفتح" قاعدة البيانات في حد ذاتها (يتم الوصول إليها عبر ADO)، فلا أعرف كيفية كتابة التعليمات البرمجية لتحديث الروابط.
المحلول
التحديث 14 أبريل 2009لقد وجدت أن الإجابة السابقة التي قدمتها هنا كانت خاطئة، لذلك قمت بتحديثها برمز جديد.
كيفية المضي قدما
- انسخ الكود أدناه إلى وحدة VBA.
من الكود أو من مباشر نافذة في VBA IDE، ببساطة اكتب:
RefreshLinksToPath Application.CurrentProject.Path
سيؤدي هذا الآن إلى إعادة ربط جميع الجداول المرتبطة لاستخدام الدليل الذي يوجد به تطبيقك.
يجب القيام بذلك مرة واحدة فقط أو كلما قمت بإعادة الارتباط أو إضافة جداول جديدة.
أوصي بالقيام بذلك من الكود في كل مرة تبدأ فيها تطبيقك.
يمكنك بعد ذلك نقل قواعد البيانات الخاصة بك دون مشاكل.
شفرة
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
collTbls.Add Item:=.Name & .Connect, key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.count To 1 Step -1
strcon = collTbls(i)
' Get the original name of the linked table '
strDBPath = Right(strcon, Len(strcon) - (InStr(1, strcon, "DATABASE=") + 8))
' Get table name from connection string '
strTbl = Left$(strcon, InStr(1, strcon, ";") - 1)
' Get the name of the linked database '
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Reconstruct the full database path with the given path '
strDBPath = strNewPath & "\" & strDBName
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = ";Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
MsgBox strMsg
Resume fRefreshLinks_End
End Select
End Function
هذا الكود مقتبس من هذا المصدر: http://www.mvps.org/access/tables/tbl0009.htm.
لقد قمت بإزالة كل الاعتماد على الوظائف الأخرى لجعلها مستقلة بذاتها، ولهذا السبب فهي أطول قليلاً مما ينبغي.
نصائح أخرى
هل تشير إلى تحديث الروابط في شكل Word أو الروابط الجدول المرتبط بين الوصول إلى قواعد البيانات الخاصة بك؟
لالسابق، وأفضل طريقة أن أعرف هو الحفاظ على سلسلة الاتصال الخاص بك (ق) على مستوى الوحدة ضمن مشروع مستند Word / VBA الخاصة بك وجعلها سلاسل CONST. ثم عند وضع سلسلة الاتصال الخاصة بك ADO كائنات الاتصال، تمريرها النسبي CONST سلسلة الاتصال.
لهذا الأخير، وأود أن يميل إلى استخدام مسار نسبي في سلسلة الاتصال إلى البيانات داخل كل قاعدة بيانات Access إلى أخرى. على سبيل المثال،
Dim connectionString as String
connectionString = ";DATABASE=" & CurrentProject.Path & "\[Database Name Here].mdb"
وإذا كما تقول، يتم نسخ قواعد البيانات معا إلى مجلد آخر (أنا <م> افتراض م> في نفس المجلد).
لم تعد إجابة Renaud تعمل في Access 2010 مع ملفات Excel أو CSV.
لقد قمت ببعض التعديلات:
- تتكيف مع النمط الحالي لسلسلة الاتصال
- التعامل مع مسار قاعدة البيانات بشكل مختلف لملفات Excel (يتضمن اسم الملف) وملفات CSV (لا يتضمن اسم الملف)
هنا هو الرمز:
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = _
TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
Debug.Print "Name: " & .Name
Debug.Print "Connect: " & .Connect
collTbls.Add Item:=.Name & ";" & .Connect, Key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.Count To 1 Step -1
strConnRaw = collTbls(i)
' Get table name from the full connection string
strTbl = Left$(strConnRaw, InStr(1, strConnRaw, ";") - 1)
' Get original database path
strDBPath = Right(strConnRaw, Len(strConnRaw) - (InStr(1, strConnRaw, "DATABASE=") + 8))
' Get the name of the linked database
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Get remainder of connection string
strConn = Mid(strConnRaw, InStr(1, strConnRaw, ";") + 1, InStr(1, strConnRaw, "DATABASE=") _
- InStr(1, strConnRaw, ";") - 1)
' Reconstruct the full database path with the given path
' CSV-Files are not linked with their name!
If Left(strConn, 4) = "Text" Then
strDBPath = strNewPath
Else
strDBPath = strNewPath & "\" & strDBName
End If
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = strConn & "Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
MsgBox strMsg
Resume fRefreshLinks_End
End Select
End Function
وأنا للأسف لا يزال على الوصول 2007. لقد بدأت مع واحدة من كتل التعليمات البرمجية أعلاه والتي لم يكن يعمل بالنسبة لي. وبعد أقل من الطاقة وصول VBA I مبسطة لسوى حلقة الأولى التي تحصل على مسارات الطاولة والتحديثات في مكانه. الرجل القادم الوقوع في هذا يمكن أن يعلق أو التحديث.
والخيار قارن قاعدة البيانات
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'
' Immediate window type
' RefreshLinksToPath Application.CurrentProject.Path
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim strDBPath As String
'Dim strTbl As String
'Dim strMsg As String
Dim strDBName As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
Dim strConn As String
Dim strNewDbConn1 As String
Dim strNewDbConn2 As String
Dim strNewDbConn As String
' On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
strConn = tdf.Connect
strDBPath = Right(strConn, Len(strConn) - (InStr(1, strConn, "DATABASE=") + 8))
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
Debug.Print ("===========================")
Debug.Print (" connect is " + strConn)
Debug.Print (" DB PAth is " + strDBPath)
Debug.Print (" DB Name is " + strDBName)
strDBNewPath = strNewPath & "\" & strDBName
Debug.Print (" DB NewPath is " + strDBNewPath)
strNewDbConn1 = Left(strConn, (InStr(1, strConn, "DATABASE=") - 1))
strNewDbConn2 = "DATABASE=" & strDBNewPath
strNewDbConn = strNewDbConn1 & strNewDbConn2
Debug.Print (" DB strNewDbConn is " + strNewDbConn)
'Change the connect path
tdf.Connect = strNewDbConn
tdf.RefreshLink
End If
End With
Next
End Function