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

**النجاشي** · نوفمبر 1, 2018

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

احبتي

عندي قاعده مقسمة وعندما انقلها لجهاز آخر ادخل على الجدوال واعيد الربط للجدوال من إدارة الجدوال المرتبطه

هل يوجد كود يغنينا عن ذالك

أو عبر قاعده خارجية تودي المهمه

شاكرين لكم احبتي

**ابوآمنة** · نوفمبر 2, 2018

أنشاء وحدة نمطية وضع الكود التالي :

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)) '

أستخدمه في برنامجي وممتاز جداً من أحد الأخوة في المنتدى وأظنه ابوخليل

تم تعديل نوفمبر 2, 2018 بواسطه saleh204

**النجاشي** · نوفمبر 2, 2018

6 ساعات مضت, saleh204 said:

أنشاء وحدة نمطية وضع الكود التالي :


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)) '

أستخدمه في برنامجي وممتاز جداً من أحد الأخوة في المنتدى وأظنه ابوخليل

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

شكرا اليك يالغالي

**محمد سلامة** · نوفمبر 2, 2018

السلام عليكم

هذا الكود لاستاذنا ابوخليل جزاه الله كل خير

وانا استعمله في برامجي وجميل جدا

ويجب ان تضع كلمة مرور علي قاعدة الجداول ومن ثم تضع الكلمة في كود الاستدعاء

تحياتي

**ابوآمنة** · نوفمبر 2, 2018

ممكن تساعندي أخي محمد سلامة

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

**محمد سلامة** · نوفمبر 3, 2018

21 ساعات مضت, saleh204 said:

ممكن تساعندي أخي محمد سلامة

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

تحت امرك حبيبي

تحتاج الي شرح مصور عندما افتح الكمبيوتر سوف اجهز الصور وارفعها لك

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

**ابوآمنة** · نوفمبر 3, 2018

27 دقائق مضت, محمد سلامة said:

تحت امرك حبيبي

تحتاج الي شرح مصور عندما افتح الكمبيوتر سوف اجهز الصور وارفعها لك

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

سأكون لك من الشاكرين أخي الحبيب محمد سلامة

إذا كان هناك شرح مصور .

**ابوآمنة** · نوفمبر 4, 2018

شكراً لقد وجدت في الملتقى ما أريد ربط قاعدة الجداول بالباسورد

المطلوب الثاني

ما هو كود الباسورد الذي اضعه في كود الاستدعاء ؟

تم تعديل نوفمبر 4, 2018 بواسطه saleh204

**ابوآمنة** · نوفمبر 5, 2018

في ٢‏/١١‏/٢٠١٨ at 22:23, محمد سلامة said:

ويجب ان تضع كلمة مرور علي قاعدة الجداول ومن ثم تضع الكلمة في كود الاستدعاء

تحياتي

من لديه الخبره !

أين أضع كلمة المرور في هذه السطور ؟

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)) '

**Barna** · نوفمبر 5, 2018

45 دقائق مضت, saleh204 said:

من لديه الخبره !

أين أضع كلمة المرور في هذه السطور ؟

الباس وورد يكتب في الوحدة النمطية السابقة وليس هنا

' انظر لموقع عبارة Barna  في الاسطر التالية
If (IsNull(strDBPassword) = True) Or (strDBPassword = "Barna") Then
       tdf.Connect = ";DATABASE=" & strNewMDB
           Else
             tdf.Connect = ";DATABASE=" & strNewMDB & ";PWD=" & strDBPassword
           End If
              tdf.RefreshLink

**محمد سلامة** · نوفمبر 5, 2018

1 ساعه مضت, Barna said:


' انظر لموقع عبارة Barna  في الاسطر التالية
If (IsNull(strDBPassword) = True) Or (strDBPassword = "Barna") Then
       tdf.Connect = ";DATABASE=" & strNewMDB
           Else
             tdf.Connect = ";DATABASE=" & strNewMDB & ";PWD=" & strDBPassword
           End If
              tdf.RefreshLink

هذا خطا اخي

التصحيح يكتب بين علامتي التنصيص "" في اول سطر في هذا الكود

2 ساعات مضت, saleh204 said:
If CheckLinks("اكتب كلمة المرور هنا") = False Then

واعتذر اخي صالح علي عدم ارفاق فيديو المطلوب سابقا والله لم ادخل علي جهازي انا اتصفح من الجوال

**Barna** · نوفمبر 5, 2018

15 دقائق مضت, محمد سلامة said:

هذا خطا اخي

التصحيح يكتب بين علامتي التنصيص "" في اول سطر في هذا الكود

أشكرك أخي على التوضيح .....

**ابوآمنة** · نوفمبر 5, 2018

شكر خاص للمبرمج محمد سلامة تم تجربة الكود يعمل 100 % :fff:

ومعذور وكان الله في عونك ،،،

شكراً Barna لقد حاولت مساعدتي .

تم تعديل نوفمبر 5, 2018 بواسطه saleh204

تسجيل الدخول

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

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

النجاشي

ابوآمنة

النجاشي

محمد سلامة

ابوآمنة

محمد سلامة

ابوآمنة

ابوآمنة

ابوآمنة

Barna

محمد سلامة

Barna

ابوآمنة

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information