اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by kaser906,

الردود الموصى بها

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

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

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

تم تعديل بواسطه محمد صلاح1
رابط هذا التعليق
شارك

ومشاركة مع الاستاذ @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

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

  • Like 3
رابط هذا التعليق
شارك

منذ ساعه, kanory said:

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

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

أ 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

 

  • Like 1
رابط هذا التعليق
شارك

 

 

 

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

 

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

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

رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

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

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

 

  • Like 1
رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

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

 

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

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

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

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

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

 

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

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

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

رابط هذا التعليق
شارك

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

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

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

تم تعديل بواسطه محمد صلاح1
رابط هذا التعليق
شارك

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

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

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

رابط هذا التعليق
شارك

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

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

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

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

 

رابط هذا التعليق
شارك

  • أفضل إجابة
9 دقائق مضت, محمد صلاح1 said:

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

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

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

image.png.96910f5fc5499e6543df791dd5652463.png

  • Thanks 1
رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

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

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

تم تعديل بواسطه محمد صلاح1
  • Like 1
رابط هذا التعليق
شارك

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

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

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

شكرا لك

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

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

الحمد لله

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

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information