اريد كود لإدارة الجداول المرتبطة

[راعي الغنم]

السلام عليكم ورحمة الله وبركاته

في البداية اود أن اعتذر عن قلة مشاركاتي بهذا المنتدى العظيم, ليس استعلاءً مني, ولكن شح الاوقات يضطرني لذلك.

وايضا لأنني لست من اهل التخصص وانما مجرد هاوٍ للاكسس ولذلك انا لا افهم كثيرا مما ينشر هنا لجهلي طبعا...

ثانيا: اريد شيفرة او كود او ماكرو لادارة الجداول المرتبطة وتحديثها بدلا من غلق نموذج الواجهة والوصول لقتعدة البيانات ثم الجداول..

كما بالصورة, ولكم جزيل الشكر والامتنان...

المحب دوما راعي الغنم

مدونة راعي الغنم

[ابوخليل]

وعليكم السلام

 

الصق هذه الاكواد في وحدة نمطية عامة

 

Public Function CheckLinks(ByVal strDBPassword As String) As Boolean
' Check linked tables relink if necessary. Returns true if
' links are okay (or links are successfully refreshed).
    On Error GoTo CheckLinksErr
     Dim tdf As TableDef
    Dim strNewMDB As String
    Dim fd As FileDialog
     ' Loop through each table in the current database.
    For Each tdf In CurrentDb.TableDefs
    If UCase(Left(tdf.name, 6)) <> "COMPAS" Then
        ' Check whether this table is linked (connect string not blank)
        ' and whether its link is broken (no fields in the Fields collection).
        If Len(tdf.Connect) > 0 And tdf.Fields.Count = 0 Then
            ' If we don't have an MDB name yet, display a message and
            ' then ask the user to pick a new file.
            If Len(strNewMDB) = 0 Then
                Call MsgBox("ملف قاعدة البيانات  قد تم نقله أو إعادة تسميته.للمواصلة الرجاء تحديد ملف البيانات.", vbCritical)
              ' Create a FileDialog object.
                Set fd = Application.FileDialog(msoFileDialogFilePicker)
                With fd
                    ' Set dialog box properties.
                    .AllowMultiSelect = False
                    .InitialFileName = CurrentDBFolder()
                    .Filters.ADD "Access Database File (*.mdb)", "*.mdb", 1
                    .Title = "Select Back-End Data File"
                    .ButtonName = "Link Tables"
                    
                    ' Show the dialog box.
                    If .Show = False Then   ' User clicked Cancel.
                        Exit Function
                    Else
                        ' Selected file is in the SelectedItems collection.
                        strNewMDB = .SelectedItems(1)
                    End If
                End With
            End If
            ' Refresh the link using the selected back-end database.
           
           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   ' Relinking was a success.


CheckLinksDone:
    Exit Function


CheckLinksErr:
    MsgBox "Error #" & err.Number & ": " & err.Description, vbCritical
    Resume CheckLinksDone
  
End Function


Public Function CurrentDBFolder() As String
' Returns the folder of the currently open database.


    Dim strPath As String
    
    strPath = CurrentDb.name


    ' Keep removing the rightmost character until it is a backslash.
    Do While Right$(strPath, 1) <> "\"
        strPath = Left$(strPath, Len(strPath) - 1)
    Loop


    CurrentDBFolder = strPath


End Function

 ثم الصق هذه في نموذج البداية

 

Private Sub Form_Load()
On Error Resume Next
If CheckLinks("") = False Then
Call Application.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)) '
Exit Sub
End Sub

[راعي الغنم]

نور الله دربك يابوخليل..

واجهتني هذي الرسالة:

compile error:user defined-type not defined

وكان التظليل على:

Dim fd As FileDialog

كما لاحظت انك صيغة القواعد في الكود هي .mdb

والقواعد عندي .accdb

فهل يلزم اغيرها بالكود والا ابقيها على حالها...

دمت اخي كريما معافى

[ابوخليل]

compile error:user defined-type not defined

تخرج هذه الرسالة عندما يكون هناك نقص في المكتبات

والمكتبة الناقصة عندك هي 

microsoft office Opject library

 

كما لاحظت انك صيغة القواعد في الكود هي .mdb

والقواعد عندي .accdb

فهل يلزم اغيرها بالكود والا ابقيها على حالها...

دمت اخي كريما معافى

 

 ' بالطبع ضروري  ولو استبدلت المتداد بــ *  النجمة لظهرت معك جميع الملفات

[راعي الغنم]

جزاك الله خير يابوخليل على سعة صدرك

الطريقة نجحت بشرط ان تكون الجداول المرتبطة في قاعدة بيانات واحدة

ولكن لما تكون الجداول في اكثر من قاعدة فهناك رسائل خطأ ويتم اغلاق البرنامج..

ووجدت طريقة اسهل لمن اراد تحديث الجداول المرتبطة باكثر من قاعدة وذلك من ماكرو

runcommand=>linkedtablemanager

حيث يتم عرض مربع الرسالة كما بالصورة المرفقة في اول الموضوع..

جزاك الله كل خير... ماقصرت وكفيت ووفيت..