وهي الطريقة التي استخدمها في اعمالي
وحدة نمطية وكود للربط داخل النموذج
انسخ الكود التالي والصقه في وحدة نمطية عامة
Public Function CheckLinks(ByVal strDBPassword As String) As Boolean
On Error GoTo CheckLinksErr
Dim tdf As TableDef
Dim strNewMDB As String
Dim fd As FileDialog
For Each tdf In CurrentDb.TableDefs
If UCase(Left(tdf.Name, 6)) <> "COMPAS" Then
If Len(tdf.Connect) > 0 And tdf.Fields.Count = 0 Then
If Len(strNewMDB) = 0 Then
Call MsgBox("مطلوب قم بتحديده واختياره (اسم قاعدة الجداول لديك) ملف البيانات", vbCritical)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.InitialFileName = CurrentDBFolder()
.Filters.ADD "Access Database File (*.mdb)", "*.mdb", 1
.TITLE = "Select Back-End Data File"
.ButtonName = "Link Tables"
If .Show = False Then
Exit Function
Else
strNewMDB = .SelectedItems(1)
End If
End With
End If
If (IsNull(strDBPassword) = True) Or (strDBPassword = "") Then
tdf.Connect = ";DATABASE=" & strNewMDB
Else
tdf.Connect = ";DATABASE=" & strNewMDB & ";PWD=" & strDBPassword
End If
tdf.RefreshLink
End If
End If
Next tdf
CheckLinks = True
CheckLinksDone:
Exit Function
CheckLinksErr:
MsgBox "Error #" & err.Number & ": " & err.Description, vbCritical
Resume CheckLinksDone
End Function
Public Function CurrentDBFolder() As String
Dim strPath As String
strPath = CurrentDb.Name
Do While Right$(strPath, 1) <> "\"
strPath = Left$(strPath, Len(strPath) - 1)
Loop
CurrentDBFolder = strPath
End Function
ثم الصق الكود التالي في حدث التحميل لنموذج البداية
On Error Resume Next
If CheckLinks("") = False Then
Call Quit
End If
Dim tdfs As DAO.TableDefs
Dim tdf As TableDef
Dim sSourceDB As String
Dim sBackupDB As String
Dim backDBName As String
Set tdfs = CurrentDb.TableDefs
Set tdf = tdfs(tdfs.Count - 1)
sSourceDB = Right(tdf.Connect, Len(tdf.Connect) - 10)
backDBName = Dir(Mid(tdf.Connect, 11))
sBackupDB = Mid(tdf.Connect, 11, Len(tdf.Connect) - (Len(backDBName) + 10)) '
وفي المثال تطبيق للمقال
ملحوظة : اذا لم يعمل المثال على الوجه الأكمل انظر في المكتبات
link_be.rar