Foksh

أصغر همومك أخي أحمد .. كمثال ؛ في حدث بعد التحديث للعنصر OptMain ، جرب الفكرة التالية أو كما تريد لحاجتك :- Private Sub OptMain_AfterUpdate() If Me.OptMain.Value = 1 Then Me.Btn_Doit.Caption = "إلغاء تفعيل مفتاح الشيفت" Else Me.Btn_Doit.Caption = "تفعيل مفتاح الشيفت" End If End Sub

اهاااا .. فهمتك الحين .. يعني كتشبيه بسيط !! كالميكانيكي الذي يريد إصلاح ماتور سيارة أثناء سيرها .. بلهجتنا الأردنية = كيف .. ليش .. وين .. متى ؟؟ هو حر يدبر راسه ، و يفك الماتور ويصلحه والسيارة شغالة . وبما أنك مصر على الوقوف عند عقدة آكسيس ، لم لا تنقل حدثك من عند الوقت الى دالتي المتواضعة ( NativeTimerCallback ) 😎 !! وبما أن كود مراقبة المجلدات لا يعتمد على التعديل الرسومي للواجهة ، فإنه سيستمر بالعمل أخي جعفر ، بل ومراقبة المجلدات كل ثانية في الخلفية ، حتى وأنت داخل محرر الأكواد ، تستطيع تكتب أكوادك بكل هدوء وسلام 😏 ..

مجهود جميل أستاذ @عبدالله بشير عبدالله ، ومتابعة جيدة جداً منكم جميعاً .. تم نقل الإجابة إلى آخر مرفق . وعله يكون الشافي لأخينا @بلانك

وعليكم السلام ورحمة الله وبركاته .. أهلاً بك معلمي الفاضل @jjafferr ، وأشكرك جداً على هذه الملاحظة الدقيقة والمهنية . نقطتك في محلها تماااااماً ؛ فالتحديث الأول أوقف التايمر الخاص به فقط ولكنه لم يتدخل في تايمرات النماذج التقليدية ( Timer Interval ) كاستخدامك لها في الـ ( Hot Folders ) ، مما استمر في مقاطعتك كمطور عند كتابتك للأكواد داخل المحرر . ولذلك ، ولحل هذه المعضلة بشكل جذري وجعل الفكرة ناجحة 100% ، قمت بتوسيع مهام حدث الويندوز ForegroundChangedProc . الفكرة الآن أنه وبمجرد مرور تركيز الويندوز إلى نافذة محرر الأكواد VBA ، سيقوم الكود بمسح جميع النماذج المفتوحة بلحظة واحدةً ، وبالتالي يحفظ قيم التايمر لها - عند وجود الحدث فقط - في ذاكرة مؤقتة ، ويجعل التايمر = 0 . وعند إغلاقك المحرر ، سيعيد الاستئناف بدقة لكل نموذج بناءً على ما تم حفظه في الذاكرة . وقد تم الاعتماد على خصيصة hWnd كمعرف فريد للنماذج بدلاً من اسمها تفادياً لأي خطأ ( في حال كنت تستدعي أكثر من نسخة لنفس الحدث ) 😅 . سنقوم بالإعلان عن متغير ( الذاكرة المؤقتة ) الذي ستعيش وتموت مع فتح وإغلاق محرر الأكواد VBA ، كالآتي :- Private colPausedForms As Collection الإضافة الثانية ( عملية الإيقاف والفكشنة عند فتح VBA ) . وتكون في الجزء الأول من دالة ForegroundChangedProc داخل شرط If IsVBEOpen() Then ، وهي المسؤولة عن حصر النماذج المفتوحة لدالة الصيد لتقوم بإيقافها وتتبع النماذج الفرعية داخلها :- Set colPausedForms = New Collection Dim frmMain As Object For Each frmMain In Forms PauseAllTimers frmMain Next frmMain الإضافة الثالثة ، وتكون في الجزء الثاني Else عند إغلاق الـمحرر ، وهي المسؤولة عن إعادة الروح للتايمرات وقيمها الأصلية كما كانت عليه :- If Not colPausedForms Is Nothing Then Dim frmMain2 As Object For Each frmMain2 In Forms ResumeAllTimers frmMain2 Next frmMain2 Set colPausedForms = Nothing End If أما الإضافة الرابعة والأخيرة 😅 ( دالتين صغيرتين بمثابة محركات البحث المتداخل ) ، لكتابة وحفظ البصمات 😁 :- Private Sub PauseAllTimers(frm As Object) If frm.TimerInterval > 0 Then On Error Resume Next colPausedForms.Add frm.TimerInterval, CStr(frm.Hwnd) frm.TimerInterval = 0 On Error GoTo 0 End If Dim ctl As Object On Error Resume Next For Each ctl In frm.Controls If ctl.ControlType = 112 Then If Not ctl.Form Is Nothing Then PauseAllTimers ctl.Form End If Next ctl On Error GoTo 0 End Sub Private Sub ResumeAllTimers(frm As Object) On Error Resume Next Dim savedInterval As Long: savedInterval = 0 savedInterval = colPausedForms(CStr(frm.Hwnd)) If savedInterval > 0 Then frm.TimerInterval = savedInterval Dim ctl As Object For Each ctl In frm.Controls If ctl.ControlType = 112 Then If Not ctl.Form Is Nothing Then ResumeAllTimers ctl.Form End If Next ctl On Error GoTo 0 End Sub الآن الكود بحلته الجديدة وملفه الجديد تالياً ( فضلاً لا أمراً ، افتح النموذج Frm_WithTimerInterval ) وضع به ما شئت من نماذج فرعية بداخل بعضها البعض ذات تايمرات مستمرة ! ثم جرب الدخول إلى المحرر Time With No TimerInterval.accdb

ليس لدي نسخة 2003 حتى أقوم بالتجربة ، ولكن الأمر مرهون بتجربتك على أكثر من إصدار أخي الكريم .. جرب كلا الحلين وأعتقد أنك سترسو على بر الإجابة بأمان .

في الحقيقة هذا الكلام كبيراً على عقلي الصغير فعلياً ، وليس لي تجربة حقيقية بهذا المجال ( الـ MCP ) .. ولكن من خلال فيديوهاتك التي ارفقتها في أحد المواضيع ، توضحت جزئياً الفكرة والهدف المرجو من الـ MCP .. من تجارب صديق لي في استخدام الذكاء الصناعي بإنشاء مشاريع بايثون ، فأكد لي فعلياً انه مجرد جعل الذكاء يفهم المطلوب حتى يقوم بإنشاء مشروع جاهز بصيغته Py على ما اذكر .. لكن لم تمر علي تجربة لإنشاء Accdb جاهز وكامل متكامل من خلال الذكاء الصناعي .. هذا والله أعلم ..

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

فعلاً ده كان رد الذكاء الصناعي لما سألته عن الكود خلاف ذلك ، ليس محل نقاش . فيما رأيته :- شكراً لتفاعلك 😎

بناءً على طلبك أخي @أحمد العيسى ، هذه مشاركة بسيطة ، جربها رجاءً على أوفيس 2003 وأخبرني بالنتيجة .. حيث الأكواد في مديول واحد :- Option Compare Database Option Explicit Private mDbPass As String Public Sub SelectExternalDB(frm As Object) Dim fd As Object Set fd = Application.FileDialog(3) fd.Title = "Select Database" fd.Filters.Clear fd.Filters.Add "Access Files", "*.accdb;*.mdb" If fd.Show = -1 Then frm.Controls("Txt_PathDB").Value = fd.SelectedItems(1) mDbPass = "" CheckShift frm, fd.SelectedItems(1) End If End Sub Public Sub CheckShift(frm As Object, dbPath As String) Dim db As Object, wrk As Object, prp As Object Dim isEnabled As Boolean Set wrk = DBEngine.Workspaces(0) On Error Resume Next Set db = wrk.OpenDatabase(dbPath, False, False, "") If Err.Number = 3031 Then Err.Clear mDbPass = InputBox("قاعدة البيانات محمية، يرجى إدخال كلمة المرور:", "كلمة المرور") If mDbPass = "" Then Exit Sub Set db = wrk.OpenDatabase(dbPath, False, False, ";PWD=" & mDbPass) End If If db Is Nothing Then Exit Sub isEnabled = True For Each prp In db.Properties If prp.Name = "AllowBypassKey" Then isEnabled = prp.Value Exit For End If Next prp If isEnabled Then frm.Controls("OptMain").Value = 2 frm.Controls("Btn_Doit").Caption = "إلغاء تفعيل مفتاح الشيفت" frm.Controls("Lbl_Info").Caption = "الحالة: مفتاح الشيفت مفعل" & vbCrLf & dbPath Else frm.Controls("OptMain").Value = 1 frm.Controls("Btn_Doit").Caption = "تفعيل مفتاح الشيفت" frm.Controls("Lbl_Info").Caption = "الحالة: مفتاح الشيفت غير مفعل" & vbCrLf & dbPath End If db.Close Set db = Nothing End Sub Public Sub ExecuteToggle(frm As Object) Dim dbPath As String dbPath = frm.Controls("Txt_PathDB").Value If Len(dbPath) = 0 Then Exit Sub Dim db As Object, wrk As Object, prp As Object Set wrk = DBEngine.Workspaces(0) On Error Resume Next If Len(mDbPass) > 0 Then Set db = wrk.OpenDatabase(dbPath, False, False, ";PWD=" & mDbPass) Else Set db = wrk.OpenDatabase(dbPath, False, False, "") End If If db Is Nothing Then Exit Sub Dim newState As Boolean If frm.Controls("OptMain").Value = 1 Then newState = True Else newState = False End If db.Properties("AllowBypassKey") = newState If Err.Number = 3270 Then Err.Clear Set prp = db.CreateProperty("AllowBypassKey", 1, newState) db.Properties.Append prp End If db.Close Set db = Nothing CheckShift frm, dbPath End Sub والإستدعاء في زر اختيار الملف :- Private Sub Btn_Select_Click() SelectExternalDB Me End Sub وزر التنفيذ :- Private Sub Btn_Doit_Click() ExecuteToggle Me End Sub وصورة من الأداة :- حيث عند اختيارك لأي قاعدة بيانات ، سيتم الكشف عن حالتها ، إن كان مفتاح الشيفت مفعلاً مسبقاً فسيتم تطبيق الإختيار تلقائياً على Disabled - غير مفعلة . وإذا كان مفتاح الشيفت غير مفعل مسبقاً ، فسيتم تطبيق الإختيار على Enabled - مفعلة . وسيكون التفعيل من خلال زر واحد فقط تتغير تسميته حسب الحالة .. وإذا كانت قاعدة البيانات محمية بكلمة مرور فسيظهر لك رسالة لإدخال كلمة مرور قاعدة البيانات فور اختيارها ، وعند تنفيذ الإجراء الذي تريده للتأكيد .. ShiftEnabled.mdb

ملفي انا المخصص للأداة ، لو قدرت على اداتي يبقى انت عملت معجزة وخدمت الشعب العربي كاملاً .. لأنه مستثنى من الكسر الكامل ، لكن تقدر تستخدم التصميم بالنسخة الحالية الخالية من الأكواد 😉 . لا تستغرب ، قد يكون هذا أحد السيناروهات اللي ممكن أسلكها في طريقة عملي .. وقت الجد سأجعلك تجرب بنفسك على أي نسخة من أي مشروع تريده ( لأني لم أستثني أي بصمة وأي مشروع لغاية الآن ) .. لذلك لا تضيع فرصتك الثمينة على ملفي .. ودائماً وأبداً ، يسعدني مروركم العطر هذا

[تعليق جعفر] بالاشارة الى الموضوع التالي بعد فصل الموضوع عن رده في موضوعه المشار إليه أعلاه .. بصوا على الخفة في الأداء😎 :- Option Compare Database Option Explicit Const TargetControlName As String = "CyberClock" '' ' اسم عنصر عرض الوقت النصي ليبل/مربع نص/زر #If VBA7 Then Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long Private Declare PtrSafe Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As LongPtr, ByVal pfnWinEventProc As LongPtr, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As LongPtr Private Declare PtrSafe Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As LongPtr) As Long Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hWnd As LongPtr, ByVal gaFlags As Long) As LongPtr Public NativeTimerID As LongPtr Private WinEventHookID As LongPtr Private AccessHwnd As LongPtr #Else Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long Private Declare Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long Private Declare Function GetAncestor Lib "user32" (ByVal hWnd As Long, ByVal gaFlags As Long) As Long Public NativeTimerID As Long Private WinEventHookID As Long Private AccessHwnd As Long #End If Private Const EVENT_SYSTEM_FOREGROUND As Long = &H3 Private Const WINEVENT_OUTOFCONTEXT As Long = &H0 Private Const GA_ROOT As Long = 2 Private gWasStoppedByVBE As Boolean Private gTimerInterval As Long #If VBA7 Then Public Sub NativeTimerCallback(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) #Else Public Sub NativeTimerCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) #End If On Error Resume Next Dim currentTime As Variant Dim timeText As String currentTime = Now() timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "dddd, dd/mm/yyyy") '' ' 1. الوقت فقط (سطر واحد) '' timeText = Format$(currentTime, "hh:nn:ss AM/PM") ' '' ' 2. التاريخ فقط (سطر واحد) '' timeText = Format$(currentTime, "dd/mm/yyyy") ' '' ' 3. الوقت والتاريخ في سطر واحد '' timeText = Format$(currentTime, "hh:nn:ss AM/PM") & " - " & Format$(currentTime, "dd/mm/yyyy") ' '' ' 4. الوقت فوق التاريخ (سطرين) '' timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "dd/mm/yyyy") ' '' ' 5. التاريخ فوق الوقت (سطرين) '' timeText = Format$(currentTime, "dd/mm/yyyy") & vbCrLf & Format$(currentTime, "hh:nn:ss AM/PM") ' '' ' 6. الوقت مع اسم اليوم والتاريخ (سطر واحد) '' timeText = Format$(currentTime, "hh:nn:ss AM/PM") & " - " & Format$(currentTime, "dddd, dd/mm/yyyy") ' '' ' 7. التاريخ مع اسم اليوم فقط (سطر واحد) '' timeText = Format$(currentTime, "dddd, dd/mm/yyyy") ' '' ' 8. التاريخ مع اسم اليوم فوق الوقت (سطرين) '' timeText = Format$(currentTime, "dddd, dd/mm/yyyy") & vbCrLf & Format$(currentTime, "hh:nn:ss AM/PM") ' '' ' 9. الوقت فقط مع ثواني بصيغة 24 ساعة '' timeText = Format$(currentTime, "HH:nn:ss") ' '' ' 10. الوقت مع التاريخ مختصر (رقم الشهر بدل اسمه) '' timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "dd/mm/yy") ' '' ' 11. تنسيق أمريكي (شهر/يوم/سنة) '' timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "mm/dd/yyyy") ' '' ' 12. مع اسم اليوم والمختصر '' timeText = Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & Format$(currentTime, "ddd, dd/mm/yyyy") ' Mon, 15/04/2026 ' '' ' 13. نص مخصص بالكامل '' timeText = "الوقت: " & Format$(currentTime, "hh:nn:ss AM/PM") & vbCrLf & "التاريخ: " & Format$(currentTime, "dddd, dd/mm/yyyy") Dim frm As Object, ctl As Object, target As Object For Each frm In Forms Err.Clear Set target = frm.Controls(TargetControlName) If Err.Number = 0 Then target.Caption = timeText target.Value = timeText End If For Each ctl In frm.Controls Err.Clear Set target = ctl.Form.Controls(TargetControlName) If Err.Number = 0 Then target.Caption = timeText target.Value = timeText End If Next ctl Err.Clear Dim LineS As Object, LineM As Object, LineH As Object Dim CX As Long, CY As Long Dim Radius As Long Set LineS = frm.Controls("LineSec") Set LineM = frm.Controls("LineMin") Set LineH = frm.Controls("LineHour") If Err.Number = 0 Then CX = frm.Controls("Line02").Left + (frm.Controls("Line02").Width / 2) CY = frm.Controls("Line01").Top + (frm.Controls("Line01").Height / 2) Radius = frm.Controls("Line02").Width / 2 Dim secAngle As Double, minAngle As Double, hrAngle As Double secAngle = Second(currentTime) * 6 minAngle = Minute(currentTime) * 6 + (Second(currentTime) * 0.1) hrAngle = (Hour(currentTime) Mod 12) * 30 + (Minute(currentTime) * 0.5) DrawClockHand LineS, CX, CY, CLng(Radius * 0.9), secAngle DrawClockHand LineM, CX, CY, CLng(Radius * 0.75), minAngle DrawClockHand LineH, CX, CY, CLng(Radius * 0.5), hrAngle End If Next frm End Sub Public Sub DrawClockHand(ByRef ctlLine As Object, ByVal CX As Long, ByVal CY As Long, ByVal L As Long, ByVal AngleDeg As Double) Const Pi As Double = 3.14159265358979 Dim Rad As Double Dim EX As Long, EY As Long Rad = AngleDeg * Pi / 180 EX = CX + (L * Sin(Rad)) EY = CY - (L * Cos(Rad)) ctlLine.Width = Abs(EX - CX) ctlLine.Height = Abs(EY - CY) If ctlLine.Width = 0 Then ctlLine.Width = 1 If ctlLine.Height = 0 Then ctlLine.Height = 1 If EX < CX Then ctlLine.Left = EX Else ctlLine.Left = CX If EY < CY Then ctlLine.Top = EY Else ctlLine.Top = CY If Sgn(EX - CX) = Sgn(EY - CY) Or Sgn(EX - CX) = 0 Or Sgn(EY - CY) = 0 Then ctlLine.LineSlant = False Else ctlLine.LineSlant = True End If End Sub Public Sub StartNativeTimer(Optional ByVal IntervalMs As Long = 500) gTimerInterval = IntervalMs If NativeTimerID = 0 Then NativeTimerID = SetTimer(0, 0, IntervalMs, AddressOf NativeTimerCallback) End If If WinEventHookID = 0 Then WinEventHookID = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0, AddressOf ForegroundChangedProc, 0, 0, WINEVENT_OUTOFCONTEXT) End If End Sub Public Sub StopNativeTimer() If NativeTimerID <> 0 Then KillTimer 0, NativeTimerID NativeTimerID = 0 End If If WinEventHookID <> 0 Then UnhookWinEvent WinEventHookID WinEventHookID = 0 End If End Sub Private Function IsVBEOpen() As Boolean On Error Resume Next IsVBEOpen = Application.VBE.MainWindow.Visible If Err.Number <> 0 Then IsVBEOpen = False On Error GoTo 0 End Function #If VBA7 Then Public Sub ForegroundChangedProc(ByVal hWinEventHook As LongPtr, ByVal eventId As Long, ByVal hWnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long) #Else Public Sub ForegroundChangedProc(ByVal hWinEventHook As Long, ByVal eventId As Long, ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long) #End If On Error Resume Next If AccessHwnd = 0 Then AccessHwnd = Application.hWndAccessApp If IsVBEOpen() Then If NativeTimerID <> 0 Then KillTimer 0, NativeTimerID NativeTimerID = 0 gWasStoppedByVBE = True End If Else If gWasStoppedByVBE Then If GetAncestor(hWnd, GA_ROOT) = AccessHwnd Then If NativeTimerID = 0 Then NativeTimerID = SetTimer(0, 0, gTimerInterval, AddressOf NativeTimerCallback) End If gWasStoppedByVBE = False End If End If End If End Sub وطبعاً الإستدعاء هيكون فقط زي كدة :- Private Sub Form_Load() StartNativeTimer End Sub Private Sub Form_Unload(Cancel As Integer) StopNativeTimer End Sub والملف البسيط ده هدية كبيرة مني لموضوعك المشار إليه نموذج يحتوي فرعي ,, ونموذج رئيسي ، وساعة بالعقارب ورقمية ... Time With No TimerInterval.accdb ودي صورة كمان تخليك تستغرب إن الوقت والساعة شغالين في وضع التصميم لو عاوز .. يعني الحدث عند الوقت ملهوش أي اعتبار عندي هنا . وما تحللش كتير في الكود يا أبو جودي ، هو بسيط و واضح ومقروء ، أصلي ما قرأتش في موضوعك غير جملتين .

..

...

تخيلوا كمية الثقة اللي نبتت في نفسي بعد هذه الردود جميعها بحلوها ومرها ، بدعمها أو بانتقادها .. جعلتني أستمر في التطوير لحد ما أوصل للمخطط اللي راسي اليابس مخطط له اتجاه الـ Accde/Mde .. ومحاولة تسخير آكسيس وترويضه كما أريد تماااااماً .. بحيث إني - أنا العبد الفقير إلى الله - أرسمله خط وهو يمشي عليه ... فالمفاجئة ستكون لكل من سجلت الأداة حضوره في السيرفر ؛ تفعيل للتجربة على استخراج الأكواد لملف واحد فقط حتى لو فرمت الكمبيوتر وغيرت كل القطع . يعني جهازك وإيميلك اللي سجلت فيهم رح يعطوك تجربة استخراج الأكواد لملف واحد فقط لا غير .. وبكل ثقة

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