نجوم المشاركات

بما إنه والحمد لله ، ما حدش تعصب .. هاي فكرتي البسيطة .. Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal l00OO1lIOI1O As LongPtr, ByVal O0lllIIl1I1 As Long, ByVal II0IOII1l1 As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal l00OO1lIOI1O As LongPtr) As Long Private lll0I01OI1I As LongPtr #Else Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal l00OO1lIOI1O As Long, ByVal O0lllIIl1I1 As Long, ByVal II0IOII1l1 As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal l00OO1lIOI1O As Long) As Long Private lll0I01OI1I As Long #End If Public Sub Ill10l0IIll0() If lll0I01OI1I <> 0 Then IOII11IIOIO10 lll0I01OI1I = SetTimer(0, 1, 0, AddressOf IOOl1IlOOOll) If lll0I01OI1I <> 0 Then End If End Sub Public Sub IOII11IIOIO10() If lll0I01OI1I <> 0 Then KillTimer 0, lll0I01OI1I lll0I01OI1I = 0 End If End Sub #If VBA7 Then Public Sub IOOl1IlOOOll(ByVal hwnd As LongPtr, ByVal IIO11OlII11 As Long, ByVal I0l110IlOI01I As LongPtr, ByVal OO1IOI100OO As Long) #Else Public Sub IOOl1IlOOOll(ByVal hwnd As Long, ByVal IIO11OlII11 As Long, ByVal I0l110IlOI01I As Long, ByVal OO1IOI100OO As Long) #End If On Error Resume Next Dim lIII0O0O11Il As Object Set lIII0O0O11Il = CallByName(Application, ChrW(86) & ChrW(66) & ChrW(69), VbGet) Dim IlIO10OI1 As Object Set IlIO10OI1 = CallByName(lIII0O0O11Il, ChrW(77) & ChrW(97) & ChrW(105) & ChrW(110) & ChrW(87) & ChrW(105) & ChrW(110) & ChrW(100) & ChrW(111) & ChrW(119), VbGet) If CallByName(IlIO10OI1, ChrW(86) & ChrW(105) & ChrW(115) & ChrW(105) & ChrW(98) & ChrW(108) & ChrW(101), VbGet) = True Then CallByName IlIO10OI1, ChrW(86) & ChrW(105) & ChrW(115) & ChrW(105) & ChrW(98) & ChrW(108) & ChrW(101), VbLet, False End If Set lIII0O0O11Il = CallByName(Application, ChrW(86) & ChrW(66) & ChrW(69), VbGet) Set IlIO10OI1 = CallByName(lIII0O0O11Il, ChrW(77) & ChrW(97) & ChrW(105) & ChrW(110) & ChrW(87) & ChrW(105) & ChrW(110) & ChrW(100) & ChrW(111) & ChrW(119), VbGet) If CallByName(IlIO10OI1, ChrW(86) & ChrW(105) & ChrW(115) & ChrW(105) & ChrW(98) & ChrW(108) & ChrW(101), VbGet) = True Then CallByName IlIO10OI1, ChrW(86) & ChrW(105) & ChrW(115) & ChrW(105) & ChrW(98) & ChrW(108) & ChrW(101), VbLet, False End If End Sub والإستدعاء يكون في زري التشغيل والايقاف :- Private Sub Btn_Stop_Click() IOII11IIOIO10 End Sub Private Sub Btn_Start_Click() Ill10l0IIll0 End Sub الملف للتجربة :- VBA Kill Obfuscate Code.accdb

بعد إذن الأخ @Foksh يبدو أن المشكلة ناتجة عن إختلاف البيئة إلى بيئة x64 لذلك قمت بعمل Debug وتعديل الأسطر التي ظهر عندها خطأ الآن التطبيق يعمل عندي بدون مشاكل 2008.rar

اخي الكريم يجب عليك التفريق بين حالتين (الجداول/الإستعلامات و النماذج/التقارير) من حيث طريقة إستعراض البيانات المرتبطة بين جدولين ففي الجداول والاستعلامات يتم إظهارها بإستخدام ورقة البيانات الفرعية Subdatasheet وهي عبارة جدول أو إستعلام آخر مرتبط بهذا الجدول أو الإستعلام وبنفس الفكرة إذا أردنا إستعراض بيانات أخرى مرتبطة ببيانات النماذج والتقارير فيجب أن تكون فيما يسمى (النماذج الفرعية Subform أو التقارير الفرعية Subreport) بالتالي فإذا أردنا إظهار البيانات بالشكل المطلوب داخل النموذج فيجب أن تكون البيانات ضمن نموذج آخر يتم إدراجه كنموذج فرعي مرفق لك الملف بعد التعديل Sub-data_sheet.accdb

1- Access Runtime 2023 (32-bit): ابحث في موقع مايكروسوفت عن: Download Microsoft Access Runtime 2023 32-bit 2- سطبه واعد تشغيل الكمبيوتر ثم اتبع التالي :- كما بالشرح . 3- حمل المجلد (RetirementDate) على فلاشة واذهب لكمبيوتر ليس عليه أوفيس وسطب (setup.exe) وبيعمل معك البرنامج بعون الله . ووافني بالرد .

انشئ موديول (ModRelinkTables) . وضع به الكود التالي :- Option Compare Database Option Explicit Public Function RelinkTables() Dim db As DAO.Database Dim tdf As DAO.TableDef Dim strOldPath As String Dim strNewPath As String Dim fDialog As Office.FileDialog Set db = CurrentDb ' افحص أول جدول مرتبط لمعرفة المسار القديم For Each tdf In db.TableDefs If Len(tdf.Connect) > 0 Then strOldPath = Mid(tdf.Connect, InStr(tdf.Connect, "DATABASE=") + 9) Exit For End If Next ' لو الملف مش موجود If Dir(strOldPath) = "" Then MsgBox "الملف غير موجود، اختر مكانه الجديد." ' افتح مربع اختيار ملف Set fDialog = Application.FileDialog(msoFileDialogFilePicker) With fDialog .Title = "اختر ملف قاعدة البيانات الجديدة" .AllowMultiSelect = False If .Show = -1 Then strNewPath = .SelectedItems(1) Else MsgBox "لم يتم اختيار ملف." Exit Function End If End With ' حدث روابط الجداول For Each tdf In db.TableDefs If Len(tdf.Connect) > 0 Then tdf.Connect = ";DATABASE=" & strNewPath tdf.RefreshLink End If Next MsgBox "تم تحديث الروابط بنجاح." End If End Function المكتبات المطلوبة: Microsoft DAO 3.6 Object Library أو Microsoft Office xx.0 Access Database Engine Object Library (لتعريف DAO.Database و DAO.TableDef) Microsoft Office xx.0 Object Library (لتعريف Office.FileDialog) Microsoft Access xx.0 Object Library (مفعّل تلقائياً) ملاحظات: استخدم Option Explicit عشان يجبرك على تعريف كل المتغيرات، وده بيمنع أخطاء وقت التشغيل. الكود بيستخدم DAO و Office بشكل صريح، فلو المكتبات مش مفعّلة هتظهر لك رسالة خطأ واضحة بدل ما يشتغل بشكل غير متوقع. تقدر تستدعي الدالة RelinkTables في حدث On Load للنموذج الرئيسي أو في ماكرو AutoExec.

ممكن مرفق لتوضيح طلبك .

المرفق VBAMonitor.accdb

تفضلي أختي الكريمه : مي الكيال قاعدة بيانات بها نموذج وتفتح لك ملف وورد بناء على طلبك بالتوفيق اخي الغالي : جعفر السلام عليكم ورحمة الله وبركاته اتمنى ان تكون بصحة جيده انت وجميع الأخوة الكرام هنا في المنتدى اختكم : زهره محمد العبدالله ( أم عهود ) zahrah.rar