أنشاء وحدة نمطية وضع الكود التالي :
Option Compare Database
Option Explicit
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("مطلوب قم بتحديده واختياره (Market_be.accdb) ملف البيانات", vbCritical)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.InitialFileName = CurrentDBFolder()
.Filters.Add "Access Database File (*.accdb)", "*.accdb", 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
ثم استدعيها بأول نموذج يفتح لبرنامجك .
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)) '
أستخدمه في برنامجي وممتاز جداً من أحد الأخوة في المنتدى وأظنه ابوخليل