تجديد الارتباط تلقائياً بمسار جديد للجداول المرتبطة التي لها باسوود

[محمد صلاح1]

ارجو من الأخوة ممن لديه حل محترف لكيفية تجديد مسار ربط الاتصال برمجياً أي تلقائياً بدون تدخل يدوي بقاعدتي بيانات الجداول المرتبطة لهما باسوورد 

بحيث كلما تم تغيير مكان مجلد العمل من جهاز لأخر يتم الربط والاتصال دون أن يأخذ ذلك وقت طويل أو تظهر مشاكل في إدخال البيانات لهذه الجداول أثناء العمل

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

تم تعديل أغسطس 1, 2019 بواسطه محمد صلاح1

[محمد صلاح1]

للرفع

[kanory]

انظر هذا المثال للأخ اعتقد  MAXXIN

 

AutoConnectMultipleDBsWithPW.rar

[kaser906]

ومشاركة مع الاستاذ @kanory

احد روائع الاستاذ أبو يوسف الله يجزاه بالخير

 

استخدم هذه الاكواد ف نموذج بدء التشغيل

 

Const mypswd As String = "الرقم السري"
Const bnd As String = "أسم قاعدة البيانات الخلفية .أمتداد الملف"

عند فتح النموذج

 On Error Resume Next
 Dim bkend As String
 If Dir(CurrentProject.Path & "\" & bnd) <> "" Then bkend = CurrentProject.Path & "\" & bnd
 If acbRelink(Nz(bkend, ""), True, mypswd) Then
 DoCmd.Close
 End If

Private Function acbRelink(strpath As String, Optional blnSilent As Boolean = True, Optional paswd As String = "") As Boolean
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Call SysCmd(acSysCmdSetStatus, "Re-linking the data tables...")
    Set db = CurrentDb()
    For Each tdf In db.TableDefs
        If (tdf.Attributes And dbAttachedTable) = _
         dbAttachedTable Then
            tdf.Connect = "MS Access;DATABASE=" & strpath & ";" & "PWD=" & paswd & ";"
tdf.RefreshLink
End If
    Next
    Call SysCmd(acSysCmdClearStatus)
    acbRelink = True
ExitHere:
    Call SysCmd(acSysCmdClearStatus)
    Exit Function
    
HandleErrors:
    acbRelink = False
    Select Case Err.Number
     Case 3011
        Case Else
            If Not blnSilent Then
                MsgBox Err.Description, , _
                 "acbRelink Error " & Err.Number
            End If
    End Select
    Resume ExitHere
End Function

::بالتوفيق::

[محمد صلاح1]

منذ ساعه, kanory said:

انظر هذا المثال للأخ اعتقد  MAXXIN

أ kanoryشكر للتفاعل المثمر أعتقد أنه مثال جيد لمن يريد فعل ذلك يدوياً وأنا كما ذكرت في البداية أريد تنفيذ ذلك تلقائياً من خلال الأكواد بصورة غير مرئية او محسوسة

أ kaser906  ما تفضلت به قريب جداً مما أريد ولكن بداية وقبل تطبيقه علي عملي أريد كما ذكرت في البداية أن يعمل الكود علي ربط قاعدتين للجداول المرتبطة وليست واحدة والكود المرفوع لقاعدة واحدة فأريد تطويعة قبل تطبيقه ليعمل علي ربط قاعدتين مع القاعدة الرئيسية للواجهات وشكرا لكم

 

[kaser906]

1 ساعه مضت, محمد صلاح1 said:

ما تفضلت به قريب جداً مما أريد ولكن بداية وقبل تطبيقه علي عملي أريد كما ذكرت في البداية أن يعمل الكود علي ربط قاعدتين للجداول المرتبطة وليست واحدة والكود المرفوع لقاعدة واحدة فأريد تطويعة قبل تطبيقه ليعمل علي ربط قاعدتين مع القاعدة الرئيسية للواجهات وشكرا لكم

ستكون الاكواد بهذه الطريقة

Const mypswd As String = "الرقم السر لقاعدة البيانات الأولى"
Const mypswd2 As String = "الرقم السري لقاعدة البيانات الثانية"
Const bnd As String = "أسم قاعدة البيانات الأولى.امتداد القاعدة"
Const bnd2 As String = "أسم قاعدة البيانات الثانية.أمتداد القاعدة"

 Dim bkend As String
  Dim bkend2 As String
 If Dir(CurrentProject.Path & "\" & bnd) <> "" Then bkend = CurrentProject.Path & "\" & bnd
 If acbRelink(Nz(bkend, ""), True, mypswd) Then
 End If
  If Dir(CurrentProject.Path & "\" & bnd2) <> "" Then bkend2 = CurrentProject.Path & "\" & bnd2
  If acbRelink2(Nz(bkend2, ""), True, mypswd2) Then
 DoCmd.Close
 End If

Private Function acbRelink(strpath As String, Optional blnSilent As Boolean = True, Optional paswd As String = "") As Boolean
    
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Call SysCmd(acSysCmdSetStatus, "Re-linking the data tables...")
    Set db = CurrentDb()
    For Each tdf In db.TableDefs
        If (tdf.Attributes And dbAttachedTable) = _
         dbAttachedTable Then
            tdf.Connect = "MS Access;DATABASE=" & strpath & ";" & "PWD=" & paswd & ";"
            On Error Resume Next
            tdf.RefreshLink
       On Error GoTo 0
        End If
    Next
    Call SysCmd(acSysCmdClearStatus)
    acbRelink = True
ExitHere:
    Call SysCmd(acSysCmdClearStatus)
    Exit Function
    
HandleErrors:
    acbRelink = False
    Select Case Err.Number
     Case 3011
        Case Else
            If Not blnSilent Then
                MsgBox Err.Description, , _
                 "acbRelink Error " & Err.Number
            End If
    End Select
    Resume ExitHere
End Function

Private Function acbRelink2(strpath As String, Optional blnSilent As Boolean = True, Optional paswd As String = "") As Boolean
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Call SysCmd(acSysCmdSetStatus, "Re-linking the data tables...")
    Set db = CurrentDb()
    For Each tdf In db.TableDefs
        If (tdf.Attributes And dbAttachedTable) = _
         dbAttachedTable Then
            tdf.Connect = "MS Access;DATABASE=" & strpath & ";" & "PWD=" & paswd & ";"
            On Error Resume Next
            tdf.RefreshLink
       On Error GoTo 0
        End If
    Next
    Call SysCmd(acSysCmdClearStatus)
    acbRelink2 = True
ExitHere:
    Call SysCmd(acSysCmdClearStatus)
    Exit Function
    
HandleErrors:
    acbRelink2 = False
    Select Case Err.Number
     Case 3011
        Case Else
            If Not blnSilent Then
                MsgBox Err.Description, , _
                 "acbRelink2 Error " & Err.Number
            End If
    End Select
    Resume ExitHere
End Function

 

[eng aoff]

 

 

 

23 ساعات مضت, kaser906 said:

ستكون الاكواد بهذه الطريقة

Const mypswd As String = "الرقم السر لقاعدة البيانات الأولى"
Const mypswd2 As String = "الرقم السري لقاعدة البيانات الثانية"
Const bnd As String = "أسم قاعدة البيانات الأولى.امتداد القاعدة"
Const bnd2 As String = "أسم قاعدة البيانات الثانية.أمتداد القاعدة"

 Dim bkend As String
  Dim bkend2 As String
 If Dir(CurrentProject.Path & "\" & bnd) <> "" Then bkend = CurrentProject.Path & "\" & bnd
 If acbRelink(Nz(bkend, ""), True, mypswd) Then
 End If
  If Dir(CurrentProject.Path & "\" & bnd2) <> "" Then bkend2 = CurrentProject.Path & "\" & bnd2
  If acbRelink2(Nz(bkend2, ""), True, mypswd2) Then
 DoCmd.Close
 End If

Private Function acbRelink(strpath As String, Optional blnSilent As Boolean = True, Optional paswd As String = "") As Boolean
    
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Call SysCmd(acSysCmdSetStatus, "Re-linking the data tables...")
    Set db = CurrentDb()
    For Each tdf In db.TableDefs
        If (tdf.Attributes And dbAttachedTable) = _
         dbAttachedTable Then
            tdf.Connect = "MS Access;DATABASE=" & strpath & ";" & "PWD=" & paswd & ";"
            On Error Resume Next
            tdf.RefreshLink
       On Error GoTo 0
        End If
    Next
    Call SysCmd(acSysCmdClearStatus)
    acbRelink = True
ExitHere:
    Call SysCmd(acSysCmdClearStatus)
    Exit Function
    
HandleErrors:
    acbRelink = False
    Select Case Err.Number
     Case 3011
        Case Else
            If Not blnSilent Then
                MsgBox Err.Description, , _
                 "acbRelink Error " & Err.Number
            End If
    End Select
    Resume ExitHere
End Function

Private Function acbRelink2(strpath As String, Optional blnSilent As Boolean = True, Optional paswd As String = "") As Boolean
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Call SysCmd(acSysCmdSetStatus, "Re-linking the data tables...")
    Set db = CurrentDb()
    For Each tdf In db.TableDefs
        If (tdf.Attributes And dbAttachedTable) = _
         dbAttachedTable Then
            tdf.Connect = "MS Access;DATABASE=" & strpath & ";" & "PWD=" & paswd & ";"
            On Error Resume Next
            tdf.RefreshLink
       On Error GoTo 0
        End If
    Next
    Call SysCmd(acSysCmdClearStatus)
    acbRelink2 = True
ExitHere:
    Call SysCmd(acSysCmdClearStatus)
    Exit Function
    
HandleErrors:
    acbRelink2 = False
    Select Case Err.Number
     Case 3011
        Case Else
            If Not blnSilent Then
                MsgBox Err.Description, , _
                 "acbRelink2 Error " & Err.Number
            End If
    End Select
    Resume ExitHere
End Function

 

جزاك الله خيراً استاذي العزيز 

اين اضع الكودات بالضبط

[eng aoff]

للرفع

[kaser906]

في ١‏/٨‏/٢٠١٩ at 23:36, kaser906 said:

استخدم هذه الاكواد ف نموذج بدء التشغيل

وننتظر رد وإجابة @محمد صلاح1

هل عملت الاكواد لديه أم لا

[محمد صلاح1]

24 دقائق مضت, kaser906 said:

وننتظر رد وإجابة @محمد صلاح1

بالإضافة إلي أني كنت مشغولاً في أمور أخري أنا أيضاً كنت منتظر لإجابتك مع أخانا السائل لأني لم أعرف أيضاً أين الأكواد بالضبط

[kaser906]

28 دقائق مضت, محمد صلاح1 said:

بالإضافة إلي أني كنت مشغولاً في أمور أخري أنا أيضاً كنت منتظر لإجابتك مع أخانا السائل لأني لم أعرف أيضاً أين الأكواد بالضبط

تم وضع مثال على الرابط التالي

 

[محمد صلاح1]

شكراً جزيلاً للاخ @kaser906 علي متابعته ومجهوده الطيب

وأسمح لي بعد التجربة والتطبيق بإجراء تعديل طفيف علي الكود لتسريع الربط إذا أمكن ذلك

فعند فتح قاعدة الواجهات تأخذ وقتاً كبيراً لإجراء الربط بقاعدتي الجداول المرتبطة علماً بأن بهم جداول كثيرة وكذلك يأخذ وقتاً كبيراً عند فتح جدول ضمن أحد القاعدتين به حقول كثيرة وهذا من شأنه بطء إدخال البيانات وربما فقد بعضها

[kaser906]

في ١‏/٨‏/٢٠١٩ at 11:31, محمد صلاح1 said:

دون أن يأخذ ذلك وقت طويل أو تظهر مشاكل في إدخال البيانات لهذه الجداول أثناء العمل

 

20 دقائق مضت, محمد صلاح1 said:

فعند فتح قاعدة الواجهات تأخذ وقتاً كبيراً لإجراء الربط بقاعدتي الجداول المرتبطة علماً بأن بهم جداول كثيرة

انا استخدمت الكود مع قاعدة بيانات تحتوي على اكثر من 70 جدول وبعض الجداول تحتوي على اكثر من 40 حقل

ويتم الربط في غضون عشر ثواني أول اقل

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

 

23 دقائق مضت, محمد صلاح1 said:

وأسمح لي بعد التجربة والتطبيق بإجراء تعديل طفيف علي الكود لتسريع الربط إذا أمكن ذلك

يمكنك التعديل والتجربه وفي حال توصلت لحل نأمل إفادتنا

[محمد صلاح1]

40 دقائق مضت, kaser906 said:

يمكنك التعديل والتجربه وفي حال توصلت لحل نأمل إفادتنا

أخي الكريم قد فهمتني بالعكس فهذا طلبي منك بإجراء تعديل طفيف لحل إشكال طول الوقت فأنت المبرمج صاحب الكود

تم تعديل أغسطس 3, 2019 بواسطه محمد صلاح1

[kaser906]

1 ساعه مضت, محمد صلاح1 said:

خي الكريم قد فهمتني بالعكس فهذا طلبي منك بإجراء تعديل طفيف لحل إشكال طول الوقت فأنت المبرمج صاحب الكود

لم اجد مشكلة مما ذكرت  على ماذا اعدل ؟

[محمد صلاح1]

2 ساعات مضت, kaser906 said:

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

أثناء بحثي وجدت كود لتنفيذ ذلك ولكن عند تجربته وجدت هذا البطء في الفتح والذي يستغرق وقتاً لهذا طرحت الموضوع لعلي أجد شيئا جديداً او مختلفاً ولكن النتيجة واحدة

والإشكال ليس في البرنامج لأني بمجرد أن أزيل كلمة السر من القاعدتين بتلاشي الإشكال ويتم الربط بشكل طبيعي بدون بطء أو استغراق لوقت طويل في فتح القاعدتين فالإشكال مرتبط إذا بوضع كلمة سر لقاعدتي الجداول المرتبطة وهذا مطلب اساسي لا يمكن الاستغناء عنه باعتباره أحد أهم سبل حمايتهم

 

[kaser906]

9 دقائق مضت, محمد صلاح1 said:

أثناء بحثي وجدت كود لتنفيذ ذلك ولكن عند تجربته وجدت هذا البطء في الفتح والذي يستغرق وقتاً لهذا طرحت الموضوع لعلي أجد شيئا جديداً او مختلفاً ولكن النتيجة واحدة

والإشكال ليس في البرنامج لأني بمجرد أن أزيل كلمة السر من القاعدتين بتلاشي الإشكال ويتم الربط بشكل طبيعي بدون بطء أو استغراق لوقت طويل في فتح القاعدتين فالإشكال مرتبط إذا بوضع كلمة سر لقاعدتي الجداول المرتبطة وهذا مطلب اساسي لا يمكن الاستغناء عنه باعتباره أحد أهم سبل حمايتهم

جرب الخيار كما بالصورة

[محمد صلاح1]

وكيف أصل للخيارين الموجودين بالصورة أين أجدهما ؟

[kaser906]

من القائمة خيارات >>>>>> إعدادات العميل

[محمد صلاح1]

تمام الآن هل ألغي الباسورد القديمة ثم أعدل الخيارات ثم أعيد الباسورد ثم أحذف الجداول المرتبطة القديمة وأعيد الربط مع بعد الباسورد الجديدة هل هذا صحيح ام أن هناك ترتيب اخر هو الصحيح ؟

[kaser906]

نعم

[ابوآمنة]

ما شاء الله تبارك الله 

استفدنا من هذه المعلومات القيمة .

شكراً لمعلمنا ابومحمد 

والزميل / محمد صلاح 

[محمد صلاح1]

أ @kaser906 بارك الله فيك الآن حلت المشكلة بفضل الله ثم بمجهودكم ومتابعتكم جزاكم الله خيرا وسامحني إذ اتعبتك معي

أ @ابوآمنة الشكر موصول لكم ولكل ما يفيد بعلم ويتعامل بحلم

تم تعديل أغسطس 3, 2019 بواسطه محمد صلاح1

[kaser906]

12 دقائق مضت, ابوآمنة said:

شكراً لمعلمنا ابومحمد 

كلنا تلاميذ ومازلنا نتعلم أخي أبو @ ابوآمنة

شكرا لك

4 دقائق مضت, محمد صلاح1 said:

الآن حلت المشكلة

الحمد لله

::بالتوفيق::