ابو جودي

فكرة إن الساعة تشتغل حتى في وضع التصميم : مش ميزة بحد ذاتها بالعكس دي إشارة إن الكود شغال خارج دورة حياة أكسس الطبيعية النقطة هنا مش إن "الكود يشتغل وخلاص" لكن يشتغل بشكل قابل للتوسعة ويكون مستقر ومتوافق مع بيئة أكسس الحل المعتمد على SetTimer بسيط في الظاهر لكنه : يعمل خارج دورة عمل النماذج الطبيعية ويمر على جميع النماذج مع كل تحديث زمني ولا يملك إدارة حالة مستقلة لكل نموذج فوق ده كله الاعتماد على On Error Resume Next معناه تجاهل الأخطاء بدل حلها وكأن المشكلة ستختفي بمجرد إخفائها وهذا ليس حلا بل تأجيل للأزمة فقط ومع نمو التطبيق، النتيجة المتوقعة واضحة: تراجع في الاستقرار و انخفاض في الأداء وزيادة في صعوبة الصيانة في المقابل الاعتماد على و استخدام TimerInterval داخل النماذج يعمل داخل دورة الحياة الطبيعية للنماذج ويعتمد على الأحداث بدل المتابعة المستمرة ويتيح تحكما مستقلا لكل نموذج أما نقطة "ما تحللش كتير في الكود ، هو بسيط و واضح ومقروء" : دي مش حجة على قوة و لا على كفائة الكود فهي لا تعكس بساطته بل تتجاهل تقييم تصميمه وتأثيره على المدى الطويل الخلاصة: من يريد كودا قابلا للتوسع والاستقرار يختار TimerInterval أما من يريد حلا سريعا يبدو ذكيا في اللحظة الأولى فليستمر مع SetTimer فالفرق هنا مش تعقيد مقابل بساطة بل: تصميم موجه للتوسع والاستقرار مقابل حل عام سريع التنفيذ البساطة مطلوبة لكن البساطة الحقيقية هي اختيار بنية صحيحة تفضل ثابتة مع نمو التطبيق مش مجرد تقليل عدد الأسطر

..

..

انتم الاروع استاذ @منتصر الانسي سعيد جدا جدا جدا ان أفكارى المتواضعة نالت رضاكم اهلا استاذ @محمد سلامة انت الاحلى والاجمل اما بالنسبة للحجات الجديدة ... هو من فضل الله سبحانه وتعالى وما يغلى على احبابى ورواد المنتدى المحترمين

سبب الخطأ الاستعلام: acc_update وهذه هى جملة SQL الصحيحة للاستعلام UPDATE tbDatails INNER JOIN tbAcc ON tbDatails.idofacc = tbAcc.idofacc SET tbDatails.namofacc = tbAcc.namofacc; الخطأ من صياغة الاستعلام نفسه وليس من زر الأمر لذلك On Error Resume Next لن يمنع المشكلة بل فقط يخفيها جملة UPDATE ... INNER JOIN : يجب أن يكون التحديث على جدول واحد فقط وأنت كنت كاتب SET لحقول من tbDatails وكان فى بداية الاستعلام تقول UPDATE tbAcc وهو ده سبب الخطأ 3075 تقريبا عند بناء التعبير وفى زر الأمر : الأفضل تضيف معالجة خطأ صحيحة بدلا من استخدام SetWarnings False فقط يعنى يكون كود زر الامر بالشكل ده Private Sub COMUPDATA_Click() On Error GoTo Err_Handler DoCmd.SetWarnings False DoCmd.OpenQuery "acc_update" Me.Requery MsgBox "تم التحديث", vbInformation, "حفظ" Exit_Handler: DoCmd.SetWarnings True Exit Sub Err_Handler: DoCmd.SetWarnings True MsgBox Err.Number & " - " & Err.Description, vbExclamation, "خطأ" Resume Exit_Handler End Sub وأخيرا المرفق acc_0.accdb

هو المفروض ان المرفق الثانى بيدعم كل الامتدادت من المرفقات اللى حضرتك شاركتها لكن على كل حال اليك المرفق بعد عمل اعادة هيكلة شاملة للكود كاملا تفعيل وإلغاء الشفت.mdb

اتفضل استاذ تدلل قمت باضافة المرفق كموضوع فى مكتبة الموقع لاهمية ولسهولة الوصول و الحصول عليه تم عمل واضافة بعد التعديلات وكل شئ تقريبا تم شرحة فى المكتبة وتم اضافة مرفقكم مع دعم اضافة نماذج جديدة باختصار شديد التحديثات تتلخص فى التالى 1- قيمة المؤقت يتم التعامل معها بمرونة بتمريرها كمعامل لبعض الحالات المختلفة التى تستدعى تغيير هذه القيمة 2- امن فى حالة الطوارئ عند فقدان اكواد الموديول عدم توقف التطبيق من خلال : Fallback

اعرض الملف Clock With Smart Timer هذا الموضوع يعد مهماً وحيوياً لمصممي ومطوري النظم أكثر من المستخدم العادي خاصة عند استخدام حدث Timer مع أي نموذج ويريد مطور النظام فتح محرر الأكواد (VBA) في نفس وقت عرض النماذج هنا تحدث المشكلة الكلاسيكية: المطور لا يستطيع تعديل أي كود لأن التايمر النموذج يعطل التركيز داخل المحرر و يسبب أخطاء بفضل هذه الفكرة الثورية هذا الأمر أصبح من الماضي السحيق فكرة العمل باختصار 1 - عند فتح النموذج يبدأ TimerInterval تلقائياً 2 - إذا تم فتح محرر VBA بأى طريقة كانت يتم إيقاف التايمر فوراً 3 - عند إغلاق المحرر والعودة إلى النماذج يتم تشغيل التايمر من جديد تلقائياً وفوراً 4 - لا حاجة لتمرير اسم النموذج الرئيسي أو اسم عنصر الـ Subform يدوياً 5 - المطلوب فقط هو تمرير اسم عنصر التحكم الذي سيتم عرض الوقت فيه (Label أو TextBox) حسب الحاجة والرغبة مميزات الحل ذكـي : يكتشف النموذج الرئيسي والفرعي تلقائياً متعدد : يعمل مع أكثر من نموذج في نفس الوقت مـــرن : يدعم Label و TextBox كعناصر عرض للوقت آمـــن : إذا تم حذف الوحدة النمطية يتحول تلقائياً إلى Fallback Mode باستخدام دالة الوقت الرئيسية : Now() خفيف : لا يعتمد على Timer إضافي للمراقبة جاهــز : يعمل مع النماذج الرئيسية و الفرعية أو الرئيسية المستقلة أو الرئيسية والفرعية معا ----------------------------------------------------- الوحدة النمطية العامة الاسم المقترح: basClockManager الكود... Option Compare Database Option Explicit #If VBA7 Then 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 #Else 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 #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 gHook As LongPtr Private gAccessHwnd As LongPtr Private gClocks As Object Private Sub EnsureClockStore() If gClocks Is Nothing Then Set gClocks = CreateObject("Scripting.Dictionary") End If End Sub Private Function MakeClockKey(frm As Access.Form) As String On Error GoTo ErrorHandler Dim vParentForm As Access.Form Dim vControlName As String Set vParentForm = frm.Parent vControlName = GetSubformControlName(vParentForm, frm) If Len(vControlName) > 0 Then MakeClockKey = vParentForm.Name & "|" & vControlName & "|" & frm.Name Exit Function End If ErrorHandler: MakeClockKey = frm.Name End Function Private Function CreateClockState(frm As Access.Form, _ ByVal pControlName As String, _ ByVal pIntervalMS As Long) As Object Dim vState As Object Set vState = CreateObject("Scripting.Dictionary") Dim vIsSubform As Boolean Dim vParentName As String Dim vSubCtlName As String On Error Resume Next vParentName = frm.Parent.Name vSubCtlName = GetSubformControlName(frm.Parent, frm) vIsSubform = (Len(vSubCtlName) > 0) On Error GoTo 0 vState.Add "Key", MakeClockKey(frm) vState.Add "HostFormName", frm.Name vState.Add "ParentFormName", vParentName vState.Add "SubformControlName", vSubCtlName vState.Add "IsSubform", vIsSubform vState.Add "ControlName", pControlName vState.Add "WasStoppedByVBE", False vState.Add "IntervalMS", pIntervalMS Set CreateClockState = vState End Function Public Sub StartSmartClock(frm As Access.Form, _ ByVal pControlName As String, _ Optional ByVal pIntervalMS As Long = 1000) On Error GoTo ErrorHandler EnsureClockStore Dim vKey As String Dim vState As Object vKey = MakeClockKey(frm) If gClocks.Exists(vKey) Then gClocks.Remove vKey Set vState = CreateClockState(frm, pControlName, pIntervalMS) gClocks.Add vKey, vState frm.TimerInterval = pIntervalMS If gAccessHwnd = 0 Then gAccessHwnd = Application.hWndAccessApp If gHook = 0 Then gHook = SetWinEventHook( _ EVENT_SYSTEM_FOREGROUND, _ EVENT_SYSTEM_FOREGROUND, _ 0, _ AddressOf ForegroundChangedProc, _ 0, 0, _ WINEVENT_OUTOFCONTEXT) End If Exit Sub ErrorHandler: End Sub Public Sub StopSmartClock(frm As Access.Form) On Error Resume Next EnsureClockStore Dim vKey As String vKey = MakeClockKey(frm) frm.TimerInterval = 0 If gClocks.Exists(vKey) Then gClocks.Remove vKey End If If gClocks.Count = 0 Then If gHook <> 0 Then UnhookWinEvent gHook gHook = 0 End If Set gClocks = Nothing End If End Sub Public Sub SmartClockTimer(frm As Access.Form) On Error Resume Next EnsureClockStore Dim vKey As String Dim vState As Object vKey = MakeClockKey(frm) If Not gClocks.Exists(vKey) Then Exit Sub Set vState = gClocks(vKey) If IsVbeOpen() Then vState("WasStoppedByVBE") = True frm.TimerInterval = 0 Exit Sub End If Dim vTimeText As String vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM") If Len(vState("ControlName")) > 0 Then UpdateControlDisplay frm, vState("ControlName"), vTimeText 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 Private Sub UpdateControlDisplay(frm As Access.Form, ByVal pControlName As String, ByVal pDisplayText As String) On Error Resume Next Dim vControl As Access.Control Set vControl = frm.Controls(pControlName) If vControl Is Nothing Then Exit Sub Select Case vControl.ControlType Case acTextBox If vControl.Value <> pDisplayText Then vControl.Value = pDisplayText End If Case acLabel If vControl.Caption <> pDisplayText Then vControl.Caption = pDisplayText End If End Select End Sub Private Function GetSubformControlName(vParentForm As Access.Form, vChildForm As Access.Form) As String On Error Resume Next Dim vControl As Access.Control For Each vControl In vParentForm.Controls If vControl.ControlType = acSubform Then If vControl.Form Is vChildForm Then GetSubformControlName = vControl.Name Exit Function End If End If Next vControl End Function Private Function GetStateTargetForm(vState As Object, ByRef vForm As Access.Form) As Boolean On Error GoTo ErrorHandler If vState("IsSubform") Then If (SysCmd(acSysCmdGetObjectState, acForm, vState("ParentFormName")) And acObjStateOpen) = 0 Then Exit Function Set vForm = Forms(vState("ParentFormName")).Controls(vState("SubformControlName")).Form Else If (SysCmd(acSysCmdGetObjectState, acForm, vState("HostFormName")) And acObjStateOpen) = 0 Then Exit Function Set vForm = Forms(vState("HostFormName")) End If GetStateTargetForm = Not (vForm Is Nothing) Exit Function ErrorHandler: Set vForm = Nothing 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 gClocks Is Nothing Then Exit Sub If gClocks.Count = 0 Then Exit Sub If GetAncestor(hwnd, GA_ROOT) <> gAccessHwnd Then Exit Sub Dim vKey As Variant Dim vState As Object Dim vForm As Access.Form For Each vKey In gClocks.Keys Set vState = gClocks(vKey) If vState("WasStoppedByVBE") Then If GetStateTargetForm(vState, vForm) Then vForm.TimerInterval = vState("IntervalMS") Dim vTimeText As String vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM") If Len(vState("ControlName")) > 0 Then UpdateControlDisplay vForm, vState("ControlName"), vTimeText End If vState("WasStoppedByVBE") = False End If End If Next vKey End Sub ----------------------------------------------------- طريقة الاستدعاء في النماذج نموذج يعرض الوقت في Label الكود... Private Sub Form_Load() Application.Run "StartSmartClock", Me, "lblTime", 1000 End Sub Private Sub Form_Timer() Application.Run "SmartClockTimer", Me End Sub Private Sub Form_Unload(Cancel As Integer) Application.Run "StopSmartClock", Me End Sub ----------------------------------------------------- نموذج يعرض الوقت في TextBox الكود... Private Sub Form_Load() Application.Run "StartSmartClock", Me, "txtTime", 1000 End Sub Private Sub Form_Timer() Application.Run "SmartClockTimer", Me End Sub Private Sub Form_Unload(Cancel As Integer) Application.Run "StopSmartClock", Me End Sub ----------------------------------------------------- نموذج بدون عرض نصي للوقت الكود... Private Sub Form_Load() Application.Run "StartSmartClock", Me, "", 1000 End Sub Private Sub Form_Timer() Application.Run "SmartClockTimer", Me End Sub Private Sub Form_Unload(Cancel As Integer) Application.Run "StopSmartClock", Me End Sub ----------------------------------------------------- كما تلاحظون الاستدعاء سهل وموحد سواء أردنا عرض الوقت في TextBox أو Label Application.Run "StartSmartClock", Me, "", 1000 ملاحظة هامة حول معامل : TimerInterval وهو المعامل الثالث فى الاستدعاء (Interval) الرقم: 1000 هو قيمة TimerInterval يمثل الفاصل الزمني بالميلي ثانية القيمة الافتراضية : 1000 (ثانية واحدة) تم ضبطها مسبقاً داخل الوحدة النمطية هل هو إجباري؟ لايمكن حذفه والاعتماد على القيمة الافتراضية طرق الاستدعاء المختلفة مع المعامل : ' الطريقة الأولى: تمرير قيمة مخصصة (مثلاً نصف ثانية) Application.Run "StartSmartClock", Me, "lblTime", 500 ' الطريقة الثانية: حذف المعامل (يتم استخدام 1000 تلقائياً) Application.Run "StartSmartClock", Me, "lblTime" في بعض الحالات قد يرغب المصمم في عمل التالى : ساعة عادية لذلك سوف تكون قيمة : TimerInterval =1000 (ثانية واحدة) ساعة دقيقة (Stopwatch) تكون قيمة TimerInterval = 100 (جزء من الثانية) ساعة بطيئة (تحديث نادر) تكون قيمة TimerInterval = 5000 (5 ثوانٍ) لهذا السبب تم جعل هذا المعامل اختيارياً مع استخدام القيمة الإفتراضية المنطقية مع إتاحة المجال للمصمم لتغييره حسب احتياجاته ----------------------------------------------------- نموذج مع Fallback ( منتهى الأمان ) الكود... Option Compare Database Option Explicit Private mIsSmartClockActive As Boolean Private Sub Form_Load() AttemptStartSmartClock End Sub Private Sub Form_Timer() Dim vTimeText As String vTimeText = Format$(Now(), "dd/mm/yyyy hh:nn:ss AM/PM") If mIsSmartClockActive Then Application.Run "SmartClockTimer", Me Me.txtDClock = vTimeText Else ' Fallback: النموذج يحدث نفسه بنفسه Me.txtDClock = vTimeText Me.lblDClock.Caption = vTimeText End If End Sub Private Sub Form_Unload(Cancel As Integer) On Error Resume Next If mIsSmartClockActive Then Application.Run "StopSmartClock", Me End If Me.TimerInterval = 0 On Error GoTo 0 End Sub Private Sub AttemptStartSmartClock() On Error GoTo FallbackMode Application.Run "StartSmartClock", Me, "lblDClock", 1000 mIsSmartClockActive = True Exit Sub FallbackMode: Err.Clear mIsSmartClockActive = False Me.TimerInterval = 1000 End Sub ----------------------------------------------------- الخلاصة النهائية :الاستدعاء المناسب عرض الوقت في : Label LabelStartSmartClock Me, "lblTime" عرض الوقت في : TextBox StartSmartClock Me, "txtTime" بدون عرض نصى للوقت مثلا : ساعة عقارب (بدون عرض نصي) StartSmartClock Me, "" نموذج فرعي (Subform) نفس الكود - يتم اكتشافه تلقائياً نماذج متعددة في نفس الوقت مدعوم بالكامل ملاحظات مهمة إعدادات الأمان : يجب تفعيل Trust access to the VBA project object model في إعدادات Trust Center إصدار Access : يعمل مع Access 2007 والإصدارات الأحدث مراجع إضافية : لا يحتاج إلى إضافة أي مراجع Fallback Mode : إذا تم حذف الوحدة النمطية، يتحول النموذج تلقائياً إلى استخدام Now() مع هذا الحل الفريد أصبح : التحكم في TimerInterval أثناء فتح محرر VBA أمراً تلقائياً بالكامل، دون أي تدخل يدوي أو تعقيدات سهولة فتح محرر VBA و إضافة أو تعديل أى أكواد في نفس وقت عرض النماذج وبدون أن تحدث المشكلة الكلاسيكية بسبب : TimerInterval استمتع بتجربة تطوير سلسة وخالية من المشاكل صاحب الملف ابو جودي تمت الاضافه 04/15/26 الاقسام قسم الأكسيس  

يا هلا والله استاذى الجليل و معلمى القدير , استاذ @شايب حياكم الله وبياكم أستاذي الأجلّ، ومعلمي الأكرم، أطال الله بقاءكم على الخير، وأدام عليكم نعمة الفضل، وجعل العلم حيث كنتم أنيسَ مجلسٍ، وزينةَ قولٍ، وبركةَ أثرٍ. لقد وقفتُ على تعليقكم وقوفَ التلميذ بين يدي أستاذه، لا وقوفَ المتلقّي لثناءٍ يُطربه، بل وقوفَ المستفيد من ملاحظةٍ تهديه، وكلمةٍ تقومُ اعوجاج العبارة، وتردّها إلى سواء السبيل. وما كان لكلماتكم أن تقع في النفس إلا موقع القَبول، وهي صادرةٌ عن ذائقةٍ مرهفة، ودُربةٍ طويلة، وخبرةٍ عرفت للشعر موازينه، وللبيان مواضع إحسانه وإساءته. وإنّي، والله، لأرى تعقيبكم عليَّ من تمام النعمة، لا من باب المجاملة العابرة، لأن الثناء قد يسرّ صاحبه ساعةً، أمّا التوجيه الصادق فيبقى له في النفس أثرٌ، وفي الصنعة نفعٌ، وفي الطريق نورٌ يُهتدى به. وما تعلّمنا من أساتذتنا الأفاضل أن الكلمة تُترك على عِلاتها، ولا أن النص يُمرَّر على هناته، بل عهدناهم يرفقون في التنبيه، ويعدلون في الحكم، ويجمعون بين أدب النصيحة ونُبل المقصد؛ وذلك، بعينه، ما لمستُه في تعليقكم الكريم. ولقد أحسنتم، يا أستاذي، إذ جعلتم ملاحظتكم في موضعها، وأودعتموها من رفيق العبارة، ولطيف الإشارة، ما يفتح باب الفائدة من غير مشقّة، ويقيم الحجة من غير كلفة، ويُشعر المتلقي أنه بإزاء قلبٍ ناصح، لا لسانٍ متعقب. وتلك سجية الكبار من أهل العلم والأدب؛ إذا لاحظوا لم يجرحوا، وإذا قوّموا لم يفضحوا، وإذا علّموا بثّوا مع العلم مروءةً، ومع البيان رحمةً، ومع النقد إنصافًا. أما أنا، فما كنتُ يومًا أزعم لنفسي عصمةً من زلل، ولا سلامةً من نقص، وإنما هي محاولاتُ محبٍّ للقول، يمضي على هدى ما وعى، ثم لا يجد أكرم من عين أستاذه تُبصر له ما خفي، وتوقظه على ما فاته، وتدلّه على ما هو أولى وأقوم. فإن كان في النص شيءٌ استحسن، فذاك ـ بعد فضل الله ـ ثمرةُ ما تلقيناه من أمثالكم، وإن كان فيه خللٌ أو قصور، فحسبُ المرء شرفًا أن يجد من يرده برفقٍ إلى الصواب، ويأخذ بيده إلى الأحسن والأتمّ. وقد زاد تعقيبكم الكريم عودتي بهجةً، لأن عودة المرء لا تُحمد إلا إذا استقبلها أهل الفضل بقبولٍ جميل، ورعايةٍ صادقة، ونظرٍ منصف. والحمد لله الذي جعل في الطريق وجوهًا إذا حضرت اطمأنّ القلب، وإذا تكلّمت أشرقت العبارة، وإذا نبّهت كان في تنبيهها أدبُ المعلّم، ووفاءُ المحب، وهيبةُ العالم. فلكم مني، يا سيدي، أخلصُ الشكر، وأوفى الامتنان، وأصدقُ الدعاء؛ فلقد كنتم ـ كما عهدناكم ـ أستاذًا لا يقف عطاؤه عند حد التعليم، بل يتجاوزه إلى التهذيب والتقويم والإحسان. أسأل الله أن يبارك في عمركم وعلمكم، وأن يديم في الأدب ظلّكم، وأن يكتب لكم أجر ما تبثّونه من نورٍ في القلوب والعقول. وما أنا إلا تلميذٌ يعرف لأستاذه حقّه، ويوقن أن بعض الفضل مهما قيل فيه لا تحيط به العبارة، ولا توفيه الألفاظ.

وانا قلت اسبق حضرتك بوضع المثال المثال و المرفق والافكار وصاحبهم ملك يمينك استاذ @منتصر الانسي تدلل لو عند حضرتك نموذج ساعه تانى غير ده ارفق النموذج لاقوم بتطبق الفكرة عليه

ما شاء الله .. الله اكبر .. اللهم بارك ايه الجمال والحلاوة دى

تطبيق عملى للفكرة والاكواد على المثال القدبم والمستخدم سابقا فى الموضوع : مطلوب اظهار الساعة تعمل داخل النموذج (الساعة والدقائق والثواني ) من غير استخدام عداد (تايمر) النموذج ClockEngine.zip

السلام عليكم ورحمة الله تعالى وبركاته بادئ ذي بدء هذا الموضوع يعد مهما وحيويا لمصممي ومطوري النظم أكثر من المستخدم العادي جاءت فكرة هذا الموضوع بناء على موضوع سابق كان بعنوان: مطلوب إظهار الساعة تعمل داخل النموذج (الساعة والدقائق والثواني) من غير استخدام عداد (تايمر) النموذج ومن أهم ما ورد فيه هذا الاقتباس: 1- 2-وهذا الاقتباس: في الموضوع السابق كانت الفكرة تمثل حلا تقليديا لأنها اعتمدت على Timer آخر للمراقبة وهذا لم يكن مناسبا لأنه يظل يعمل أثناء تعديل الأكواد داخل محرر VBA لكن بفضل الله سبحانه وتعالى توصلت إلى حل مختلف تماما يعتمد على: TimerInterval الخاص بالنموذج نفسه مراقبة ظهور واختفاء محرر VBA استخدام Hook عند تغيير النافذة النشطة بدلا من الاعتماد على Timer إضافي فكرة العمل باختصار عند فتح النموذج يبدأ TimerInterval إذا تم فتح محرر VBA يتم إيقاف التايمر فورا عند إغلاق المحرر والعودة إلى نماذج قاعدة البيانات المفتوحة يتم تشغيل التايمر من جديد تلقائيا وفورا لا حاجة لتمرير اسم النموذج الرئيسي أو اسم عنصر الـ Subform يدويا لأن الكود يكتشف ذلك تلقائيا المطلوب فقط هو تمرير اسم عنصر التحكم الذي سيتم عرض الوقت فيه أيا كان نوعه: Label أو TextBox مميزات الحل يعمل مع النموذج الرئيسي أو المستقل يعمل مع النموذج الفرعي يعمل مع أكثر من نموذج في نفس الوقت يدعم عنصر العرض سواء كان Label أو TextBox لا يعتمد على Timer إضافي للمراقبة الوحدة النمطية العامة باسم : basSmartClock Option Compare Database Option Explicit #If VBA7 Then 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 #Else 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 #End If Private Const CLOCK_INTERVAL_MS As Long = 1000 Private Const EVENT_SYSTEM_FOREGROUND As Long = &H3 Private Const WINEVENT_OUTOFCONTEXT As Long = &H0 Private Const GA_ROOT As Long = 2 Private gHook As LongPtr Private gAccessHwnd As LongPtr Private gClocks As Object Private Sub EnsureClockStore() If gClocks Is Nothing Then Set gClocks = CreateObject("Scripting.Dictionary") End If End Sub Private Function MakeClockKey(frm As Access.Form) As String On Error GoTo EH Dim p As Access.Form Dim ctlName As String Set p = frm.Parent ctlName = GetSubformControlName(p, frm) If Len(ctlName) > 0 Then MakeClockKey = p.Name & "|" & ctlName & "|" & frm.Name Exit Function End If EH: MakeClockKey = frm.Name End Function Private Function CreateClockState(frm As Access.Form, ByVal ClockControlName As String) As Object Dim d As Object Set d = CreateObject("Scripting.Dictionary") Dim isSub As Boolean Dim parentName As String Dim subCtlName As String On Error Resume Next parentName = frm.Parent.Name subCtlName = GetSubformControlName(frm.Parent, frm) isSub = (Len(subCtlName) > 0) On Error GoTo 0 d.Add "Key", MakeClockKey(frm) d.Add "HostFormName", frm.Name d.Add "ParentFormName", parentName d.Add "SubformControlName", subCtlName d.Add "IsSubform", isSub d.Add "ClockControlName", ClockControlName d.Add "WasStoppedByVBE", False Set CreateClockState = d End Function Public Sub StartSmartClock(frm As Access.Form, ByVal ClockControlName As String) On Error GoTo EH EnsureClockStore Dim key As String Dim state As Object key = MakeClockKey(frm) If gClocks.Exists(key) Then gClocks.Remove key End If Set state = CreateClockState(frm, ClockControlName) gClocks.Add key, state frm.TimerInterval = CLOCK_INTERVAL_MS If gAccessHwnd = 0 Then gAccessHwnd = Application.hWndAccessApp End If If gHook = 0 Then gHook = SetWinEventHook( _ EVENT_SYSTEM_FOREGROUND, _ EVENT_SYSTEM_FOREGROUND, _ 0, _ AddressOf ForegroundChangedProc, _ 0, _ 0, _ WINEVENT_OUTOFCONTEXT) End If Exit Sub EH: End Sub Public Sub StopSmartClock(frm As Access.Form) On Error Resume Next EnsureClockStore Dim key As String key = MakeClockKey(frm) frm.TimerInterval = 0 If gClocks.Exists(key) Then gClocks.Remove key End If If gClocks.Count = 0 Then If gHook <> 0 Then UnhookWinEvent gHook gHook = 0 End If Set gClocks = Nothing End If End Sub Public Sub SmartClockTimer(frm As Access.Form) On Error Resume Next EnsureClockStore Dim key As String Dim state As Object key = MakeClockKey(frm) If Not gClocks.Exists(key) Then Exit Sub Set state = gClocks(key) If Application.VBE.MainWindow.Visible Then state("WasStoppedByVBE") = True frm.TimerInterval = 0 Exit Sub End If SetClockDisplay frm, state("ClockControlName"), Format$(Now(), "dd/mm/yyyy, hh:nn:ss AM/PM") End Sub Private Sub SetClockDisplay(frm As Access.Form, ByVal ClockControlName As String, ByVal ClockText As String) On Error Resume Next Dim ctl As Access.Control Set ctl = frm.Controls(ClockControlName) If ctl Is Nothing Then Exit Sub Select Case ctl.ControlType Case acTextBox ctl.Value = ClockText Case acLabel ctl.Caption = ClockText End Select End Sub Private Function GetSubformControlName(parentFrm As Access.Form, childFrm As Access.Form) As String On Error Resume Next Dim ctl As Access.Control For Each ctl In parentFrm.Controls If ctl.ControlType = acSubform Then If ctl.Form Is childFrm Then GetSubformControlName = ctl.Name Exit Function End If End If Next ctl End Function Private Function GetStateTargetForm(state As Object, ByRef frm As Access.Form) As Boolean On Error GoTo EH If state("IsSubform") Then If (SysCmd(acSysCmdGetObjectState, acForm, state("ParentFormName")) And acObjStateOpen) = 0 Then Exit Function Set frm = Forms(state("ParentFormName")).Controls(state("SubformControlName")).Form Else If (SysCmd(acSysCmdGetObjectState, acForm, state("HostFormName")) And acObjStateOpen) = 0 Then Exit Function Set frm = Forms(state("HostFormName")) End If GetStateTargetForm = Not (frm Is Nothing) Exit Function EH: Set frm = Nothing 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 gClocks Is Nothing Then Exit Sub If gClocks.Count = 0 Then Exit Sub If GetAncestor(hwnd, GA_ROOT) <> gAccessHwnd Then Exit Sub Dim k As Variant Dim state As Object Dim frm As Access.Form For Each k In gClocks.Keys Set state = gClocks(k) If state("WasStoppedByVBE") Then If GetStateTargetForm(state, frm) Then frm.TimerInterval = CLOCK_INTERVAL_MS SetClockDisplay frm, state("ClockControlName"), Format$(Now(), "dd/mm/yyyy, hh:nn:ss AM/PM") state("WasStoppedByVBE") = False End If End If Next k End Sub مثال الاستدعاء إذا كان العرض داخل Label Option Compare Database Option Explicit Private Sub Form_Open(Cancel As Integer) StartSmartClock Me, "lblClock" End Sub Private Sub Form_Timer() SmartClockTimer Me End Sub Private Sub Form_Unload(Cancel As Integer) StopSmartClock Me End Sub مثال الاستدعاء إذا كان العرض داخل TextBox Option Compare Database Option Explicit Private Sub Form_Open(Cancel As Integer) StartSmartClock Me, "txtDClock" End Sub Private Sub Form_Timer() SmartClockTimer Me End Sub Private Sub Form_Unload(Cancel As Integer) StopSmartClock Me End Sub كما تلاحظون كود الاستدعاء هو نفسه لأي نموذج سواء كان: رئيسيا فرعيا منفردا أو أكثر من نموذج معا إذا كان عرض الوقت داخل النموذج يعتمد على عنصر من النوع: Label إذا كان عرض الوقت داخل النموذج يعتمد على عنصر من النوع: TextBox كل المطلوب فقط هو تمرير اسم عنصر التحكم المستخدم في عرض الوقت ايا كان نوعه ( Label/TextBox ) : StartSmartClock Me, "اسم_عنصر_التحكم" وفى النهاية أسأل الله أن ينفع به إذا كان لدى أحد الأساتذة العظماء أو الإخوة الكرام أي ملاحظة على الكود أكون شاكرا جدا. مع خالص التحية SmartClock.accdb

وهذا المرفق فى حالة وضع الكود فى وحدة نمطية عامة لاستخدامة فى اكثر من نموذج ComboDropdown_V2.accdb

انا مش فاهم السؤال كويس لكن بقدر الامكان حسب فهمى المتواضع استخدم الكود التالى اما على مستوى النموذج او فى وحدة عامة Private m_LastForm As String Private m_LastCombo As String Public Function ToggleDropdCombo(frm As Form, ByVal strObjComboName As String) As Boolean On Error GoTo Err_Handler Dim strObjButtonName As String strObjButtonName = Screen.ActiveControl.Name If m_LastForm = frm.Name And m_LastCombo = strObjComboName Then frm.Controls(strObjButtonName).SetFocus GoTo Clean_Exit Else frm.Controls(strObjComboName).SetFocus frm.Controls(strObjComboName).Dropdown m_LastForm = frm.Name m_LastCombo = strObjComboName End If ToggleDropdCombo = True Exit Function Reset_Exit: Clean_Exit: m_LastForm = vbNullString m_LastCombo = vbNullString ToggleDropdCombo = True Exit Function Err_Handler: m_LastForm = vbNullString m_LastCombo = vbNullString MsgBox Err.Description, vbExclamation, "ToggleDropdCombo" ToggleDropdCombo = False End Function على اعتبار ان زر الامر اسمه : ToggleButtonName وان مربع السرد اسمه : ComboName يكون الاستدعاء بالشكل التالى Private Sub ToggleButtonName_Click() ToggleDropdCombo Me, "ComboName" End Sub ويستخدم نفس سطر الاستدعاء السابق مع زر أخر ومربع تحرير وسرد اخر فقط بتغير : ComboName الى اسم مربع التحرير والسرد الاخر مرفق للتجربة ComboDropdown.accdb

الفكرة رقم ( 2 ) عند الضغط على زر الامر تظهر الصورة عند الضغط على الصورة يفتح نموذج لتكبير الصورة عند الضغط على الصورة فى نموج يتم تكبير الصورة عند اعادة الضغط مرة أخرى على الصورة يتم استعادة الحجم الاصلى للصورة صورة قاعدة بيانات 02.zip

اتفضل عند الضغط على زر الامر تظهر الصورة عند الضغط على الصورة يفتح نموذج لتكبير الصورة عند الضغط على الصورة فى نموج التكبير يتم اغلاق نموذج التكبير صورة قاعدة بيانات.zip

و فى حل كمان بس انا عارف حضرتك مش بتحب الحل ده وهو ان ممكن نعمل كود يعدل اعدادت الويندوز من الريجسترى قبل بدء العمل

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

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

بالنسبة للرد على هذا السؤال نعم يوجد حل أخر وهو موجود بالتفصيل فى هذا الموضوع

نموذج مثلا باسم : frmPasswordPrompt العناصر داخل النموذج كالتالى مربع نص باسم : txtPassword زر امر للتأكيد باسم : btnOK زر امر للالغاء والاحباط باسم : btnCancel واستخدم الاكواد التالية فى هذا النموذج Private Sub Form_Load() Me.KeyPreview = True Me.txtPassword.Value = "" Me.txtPassword.SetFocus End Sub Private Sub btnOK_Click() PasswordConfirm Nz(Me.txtPassword.Value, "") DoCmd.Close acForm, Me.Name End Sub Private Sub btnCancel_Click() PasswordCancel DoCmd.Close acForm, Me.Name End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyEscape Then KeyCode = 0 btnCancel_Click End If End Sub قم بانشاء وحدة نمطية عامة اعطها مثلا اسم : basPasswordPrompt الاكواد داخل الوحدة النمطية تكون كالتالى : Option Compare Database Option Explicit Public Enum PasswordStatus psEmpty = 0 psInvalid = 1 psCancelled = 2 psMaxAttemptsExceeded = 3 psUnsupportedAction = 4 psDangerousSQL = 5 End Enum Public Enum ActionType atOpenForm = 0 atOpenQuery = 1 atOpenReport = 2 atPrintReport = 3 atDeleteAllRecords = 4 atExecuteSQL = 5 atRunGlobalFunction = 6 atRunFormMethod = 7 End Enum Private Const MAX_PASSWORD_ATTEMPTS As Long = 3 Private m_PasswordValue As String Private m_PasswordConfirmed As Boolean Private m_PasswordCancelled As Boolean Public Sub ExecuteAction( _ ByVal actionToExecute As ActionType, _ ByVal targetName As String, _ Optional ByVal expectedPassword As String = "", _ Optional ByVal callerForm As Access.Form = Nothing) On Error GoTo ErrorHandler If Len(Trim$(targetName)) = 0 Then Exit Sub Dim i As Long For i = 1 To MAX_PASSWORD_ATTEMPTS PromptPasswordForm If m_PasswordCancelled Then ShowMessage psCancelled Exit Sub End If If Len(m_PasswordValue) = 0 Then ShowMessage psEmpty GoTo NextTry End If If StrComp(m_PasswordValue, expectedPassword, vbBinaryCompare) <> 0 Then ShowMessage psInvalid GoTo NextTry End If ExecuteInternal actionToExecute, targetName, callerForm m_PasswordValue = "" Exit Sub NextTry: Next i ShowMessage psMaxAttemptsExceeded Exit Sub ErrorHandler: DoCmd.SetWarnings True m_PasswordValue = "" MsgBox Err.Number & " - " & Err.Description, vbCritical Debug.Print "ExecuteAction Error " & Err.Number & ": " & Err.Description End Sub Private Sub ExecuteInternal( _ ByVal actionToExecute As ActionType, _ ByVal targetName As String, _ ByVal callerForm As Access.Form) On Error GoTo ErrorHandler Select Case actionToExecute Case atOpenForm DoCmd.OpenForm targetName Case atOpenQuery DoCmd.OpenQuery targetName Case atOpenReport DoCmd.OpenReport targetName, acViewNormal Case atPrintReport DoCmd.OpenReport targetName, acViewNormal Case atDeleteAllRecords If MsgBox("هل أنت متأكد من حذف جميع السجلات؟", _ vbYesNo + vbCritical + vbDefaultButton2) <> vbYes Then Exit Sub End If SafeRunSQL "DELETE FROM [" & targetName & "]" Case atExecuteSQL If IsDangerousSQL(targetName) Then ShowMessage psDangerousSQL Exit Sub End If SafeRunSQL targetName Case atRunGlobalFunction Application.Run targetName Case atRunFormMethod If callerForm Is Nothing Then Exit Sub On Error Resume Next CallByName callerForm, targetName, VbMethod If Err.Number <> 0 Then MsgBox "Method '" & targetName & "' not found in form.", vbCritical Debug.Print "CallByName Error: " & Err.Description Err.Clear End If On Error GoTo ErrorHandler Case Else ShowMessage psUnsupportedAction End Select Exit Sub ErrorHandler: DoCmd.SetWarnings True MsgBox Err.Number & " - " & Err.Description, vbCritical Debug.Print "ExecuteInternal Error " & Err.Number & ": " & Err.Description End Sub Private Sub SafeRunSQL(ByVal sqlText As String) On Error GoTo ErrorHandler DoCmd.SetWarnings False DoCmd.RunSQL sqlText DoCmd.SetWarnings True Exit Sub ErrorHandler: DoCmd.SetWarnings True MsgBox "SQL Error " & Err.Number & vbCrLf & Err.Description, vbCritical Debug.Print "SafeRunSQL Error " & Err.Number & ": " & Err.Description End Sub Private Function IsDangerousSQL(ByVal sqlText As String) As Boolean Dim t As String t = Trim$(LCase$(sqlText)) If InStr(t, "drop ") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, "alter ") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, "create ") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, "truncate ") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, "--") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, "/*") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, "*/") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, ";") > 0 Then IsDangerousSQL = True: Exit Function If InStr(t, "delete ") > 0 And InStr(t, "where") = 0 Then IsDangerousSQL = True: Exit Function End If If InStr(t, "update ") > 0 And InStr(t, "where") = 0 Then IsDangerousSQL = True: Exit Function End If IsDangerousSQL = False End Function Public Sub PromptPasswordForm() m_PasswordValue = "" m_PasswordConfirmed = False m_PasswordCancelled = False DoCmd.OpenForm "frmPasswordPrompt", WindowMode:=acDialog End Sub Public Sub PasswordConfirm(ByVal passwordValue As String) m_PasswordValue = passwordValue m_PasswordConfirmed = True m_PasswordCancelled = False End Sub Public Sub PasswordCancel() m_PasswordValue = "" m_PasswordConfirmed = False m_PasswordCancelled = True End Sub Public Function GetLastPassword() As String GetLastPassword = m_PasswordValue End Function Public Function WasPasswordCancelled() As Boolean WasPasswordCancelled = m_PasswordCancelled End Function Public Sub ShowMessage(ByVal status As PasswordStatus) Dim sMsg As String Dim nIcon As Long Select Case status Case psEmpty sMsg = "الرجاء إدخال كلمة السر للمتابعة" nIcon = vbExclamation Case psInvalid sMsg = "كلمة سر خاطئة. حاول مرة أخرى" nIcon = vbCritical Case psCancelled sMsg = "تم إلغاء الإجراء" nIcon = vbInformation Case psMaxAttemptsExceeded sMsg = "تم تجاوز عدد المحاولات المسموح بها" nIcon = vbCritical Case psUnsupportedAction sMsg = "إجراء غير مدعوم" nIcon = vbExclamation Case psDangerousSQL sMsg = "تم رفض تنفيذ SQL لأسباب أمنية" nIcon = vbCritical End Select MsgBox sMsg, nIcon + vbMsgBoxRight, "مطالبة كلمة السر" End Sub '======================================================== ' امثلة الاستدعاء والاستخدام '======================================================== ' 1) فتح نموذج ' ExecuteAction atOpenForm, "FormName", "1234" ' ' 2) فتح استعلام ' ExecuteAction atOpenQuery, "QueryName", "1234" ' ' 3) فتح تقرير ' ExecuteAction atOpenReport, "ReportName", "1234" ' ' 4) طباعة تقرير ' ExecuteAction atPrintReport, "ReportName", "1234" ' ' 5) حذف سجلات ' ExecuteAction atDeleteAllRecords, "TableName", "1234" ' ' 6) تنفيذ SQL ' ExecuteAction atExecuteSQL, "UPDATE Table SET Field=1 WHERE ID=5", "1234" ' ' 7) استدعاء دالة عامة ' ExecuteAction atRunGlobalFunction, "MyFunction", "1234" ' ' 8) استدعاء دالة من النموذج الحالي ' ExecuteAction atRunFormMethod, "MyMethod", "1234", Me ' ' 9) فتح نموذج حسب كلمة المرور — في النموذج: ' Private Sub Command0_Click() ' ' Dim sPass As String ' Dim i As Long ' Const MAX_TRIES As Long = 3 ' ' For i = 1 To MAX_TRIES ' ' PromptPasswordForm ' sPass = GetLastPassword() ' ' If WasPasswordCancelled() Then ' MsgBox "تم إلغاء الإجراء", vbInformation + vbMsgBoxRight, "مطالبة كلمة السر" ' Exit Sub ' End If ' ' If Len(sPass) = 0 Then ' MsgBox "الرجاء إدخال كلمة السر للمتابعة", vbExclamation + vbMsgBoxRight, "مطالبة كلمة السر" ' GoTo NextTry ' End If ' ' Select Case sPass ' Case "123": DoCmd.OpenForm "Form1": Exit Sub ' Case "456": DoCmd.OpenForm "Form2": Exit Sub ' Case "789": DoCmd.OpenForm "Form3": Exit Sub ' Case Else ' MsgBox "كلمة سر خاطئة. حاول مرة أخرى", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر" ' End Select ' 'NextTry: ' Next i ' ' MsgBox "تم تجاوز عدد المحاولات المسموح بها", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر" 'End Sub '======================================================== وتستطيع استخدام اى شئ بتمرير و بتطبيق كلمة مرور اولا من خلال احد الاستدعاءات التالية ' 1) فتح نموذج طبعا مع تغيير : FormName باسم النموذج الذى تريد فتحه ExecuteAction atOpenForm, "FormName", "YourPassword" ' 2) فتح استعلام طبعا مع تغيير : QueryName باسم الاستعلام الذى تريد فتحه ExecuteAction atOpenQuery, "QueryName", "YourPassword" ' 3) فتح تقرير طبعا مع تغيير : ReportName باسم التقرير الذى تريد فتحه ExecuteAction atOpenReport, "ReportName", "YourPassword" ' 4) طباعة تقرير طبعا مع تغيير : ReportName باسم التقرير الذى تريد طباعته ExecuteAction atPrintReport, "ReportName", "YourPassword" ' 5) حذف سجلات طبعا مع تغيير : TableName باسم الجدول الذى تريد حذف سجلاته ExecuteAction atDeleteAllRecords, "TableName", "YourPassword" ' 6) تنفيذ SQL اكتبالجملة حسب تصميمك Dim SQLStatement As String SQLStatement = "UPDATE tblSettings SET IsActive=1 WHERE ID=" & Me.txtID.Value ExecuteAction atExecuteSQL, SQLStatement, "1234" ' 7) استدعاء دالة عامة من اى وحدة نمطية عامة ExecuteAction atRunGlobalFunction, "FunctionName", "YourPassword" ' 8) استدعاء أى وظيفة أو إجراء داخل النموذج الحالى ExecuteAction atRunFormMethod, "MethodName", "YourPassword", Me طبعا تغير كلم : YourPassword بكلمة المرور التى تريدها وكلمة المرور ليست ثابتة تستطيع تغييرها دائما مع الاستدعاءات المختلفة على سبيل المثال لو اردت فتح كل نموذج ولكل نموذج كلمة مرور خاصة به هو ExecuteAction atOpenForm, "frmA", "000" ExecuteAction atOpenForm, "frmB", "111" ExecuteAction atOpenForm, "frmC", "222" وأخيرا لو اردت فتح احد النماذج المتعددة ولكن كل نموذج حسب تمرير كلمة مرور خاصة به استخدم الكود التالى Private Sub Command0_Click() Dim sPass As String Dim i As Long Const MAX_TRIES As Long = 3 For i = 1 To MAX_TRIES PromptPasswordForm sPass = GetLastPassword() If WasPasswordCancelled() Then MsgBox "تم إلغاء الإجراء", vbInformation + vbMsgBoxRight, "مطالبة كلمة السر" Exit Sub End If If Len(sPass) = 0 Then MsgBox "الرجاء إدخال كلمة السر للمتابعة", vbExclamation + vbMsgBoxRight, "مطالبة كلمة السر" GoTo NextTry End If Select Case sPass Case "123": DoCmd.OpenForm "Form1": Exit Sub Case "456": DoCmd.OpenForm "Form2": Exit Sub Case "789": DoCmd.OpenForm "Form3": Exit Sub Case Else MsgBox "كلمة سر خاطئة. حاول مرة أخرى", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر" End Select NextTry: Next i MsgBox "تم تجاوز عدد المحاولات المسموح بها", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر" End Sub فعندما يتم فتح نموذج المطالبة بكلمة مرور لو تم استخدام كلمة المرور : 123 يتم فتح النموذج : Form1 لو تم استخدام كلمة المرور : 456 يتم فتح النموذج : Form2 لو تم استخدام كلمة المرور : 789 يتم فتح النموذج : Form3 بديل InputBox.accdb

الكود الافضل فى الوحدة النمطية تتم كتابته بالشكل التالى Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function CallNextHookEx Lib "user32" _ (ByVal hHook As LongPtr, ByVal nCode As Long, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _ (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As LongPtr, _ ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As LongPtr) As Long Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" _ (ByVal hWnd As LongPtr, ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function EnumChildWindows Lib "user32" _ (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, _ ByVal lParam As LongPtr) As Long Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As LongPtr, ByVal wMsg As Long, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long Private m_hHook As LongPtr #Else Private Declare Function CallNextHookEx Lib "user32" _ (ByVal hHook As Long, ByVal nCode As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _ (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, _ ByVal hMod As Long, ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _ (ByVal hWnd As Long, ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function EnumChildWindows Lib "user32" _ (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, _ ByVal lParam As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long Private m_hHook As Long #End If Private Const WH_CBT As Long = 5 Private Const HCBT_ACTIVATE As Long = 5 Private Const HC_ACTION As Long = 0 Private Const EM_SETPASSWORDCHAR As Long = &HCC Private Const EM_GETPASSWORDCHAR As Long = &HD2 Private Const PASSWORD_CHAR As Long = 42 Private Const DIALOG_CLASS As String = "#32770" Private Const EDIT_CLASS As String = "Edit" #If VBA7 Then Public Function EnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As LongPtr) As Long Dim sClass As String Dim nChars As Long Dim verifyChar As LongPtr #Else Public Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long Dim sClass As String Dim nChars As Long Dim verifyChar As Long #End If sClass = String$(256, vbNullChar) nChars = GetClassName(hWnd, sClass, 255) If nChars <= 0 Then EnumChildProc = 1 Exit Function End If If Left$(sClass, nChars) <> EDIT_CLASS Then EnumChildProc = 1 Exit Function End If SendMessage hWnd, EM_SETPASSWORDCHAR, PASSWORD_CHAR, 0 verifyChar = SendMessage(hWnd, EM_GETPASSWORDCHAR, 0, 0) If verifyChar = PASSWORD_CHAR Then EnumChildProc = 0 Else EnumChildProc = 1 End If End Function #If VBA7 Then Public Function HookCallback(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr #Else Public Function HookCallback(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long #End If Dim sClassName As String Dim nChars As Long If nCode < HC_ACTION Then HookCallback = CallNextHookEx(m_hHook, nCode, wParam, lParam) Exit Function End If If nCode = HCBT_ACTIVATE Then sClassName = String$(256, vbNullChar) nChars = GetClassName(wParam, sClassName, 255) If nChars > 0 Then If Left$(sClassName, nChars) = DIALOG_CLASS Then EnumChildWindows wParam, AddressOf EnumChildProc, 0 End If End If End If HookCallback = CallNextHookEx(m_hHook, nCode, wParam, lParam) End Function Public Function SecureInputBox( _ ByVal Prompt As String, _ Optional ByVal Title As String = "", _ Optional ByRef WasCancelled As Boolean = False, _ Optional ByVal XPos As Long = -1, _ Optional ByVal YPos As Long = -1) As String Dim sResult As String Dim threadID As Long #If VBA7 Then Dim hMod As LongPtr #Else Dim hMod As Long #End If If Len(Trim$(Prompt)) = 0 Then err.Raise vbObjectError + 1001, "SecureInputBox", "Prompt cannot be empty." End If On Error GoTo SafeExit threadID = GetCurrentThreadId() hMod = GetModuleHandle(vbNullString) m_hHook = SetWindowsHookEx(WH_CBT, AddressOf HookCallback, hMod, threadID) If m_hHook = 0 Then err.Raise vbObjectError + 1002, "SecureInputBox", "Failed to install Windows hook." End If If XPos >= 0 And YPos >= 0 Then sResult = InputBox(Prompt, Title, "", XPos, YPos) Else sResult = InputBox(Prompt, Title, "") End If WasCancelled = (StrPtr(sResult) = 0) SecureInputBox = sResult SafeExit: If m_hHook <> 0 Then UnhookWindowsHookEx m_hHook m_hHook = 0 End If If err.Number <> 0 Then Dim errNum As Long, errDesc As String errNum = err.Number errDesc = err.Description err.Clear err.Raise errNum, "SecureInputBox", errDesc End If End Function Public Sub ZeroString(ByRef sValue As String) If Len(sValue) > 0 Then sValue = String$(Len(sValue), vbNullChar) End If End Sub فى زر الامر يتم الاستدعاء بالشكل التالى Dim strPWord As String Dim strTitle As String Dim isCancel As Boolean strTitle = "سبحان الله وبحمده سبحان الله العظيم" strPrompt = "كلمة المرور مطلوبة للمتابعة." strPWord = SecureInputBox(strPrompt, strTitle, isCancel) If isCancel Then Exit Sub If strPWord = "1001" Then DoCmd.OpenForm "frmPassStars", acNormal Else MsgBox "الرقم السري الذي أدخلته غير صحيح - من فضلك أدخل الرمز الصحيح", vbExclamation, str_Title End If ZeroString strPWord

خلينا نرد الرقم &H1324 مش ثابت بيشتغل في أغلب الحالات لكن ممكن يفشل حسب إصدار الاوفيس او الويندوز دا غير ان لو حصل Error قبل : UnhookWindowsHookEx hHook الهـوك هيفضل شغال فى زر الامر تم استخدام : Cancel = True Cancel بيستخدم فقط في Events فيها معامل : Cancel مثلا زى : Form_BeforeUpdate(Cancel As Integer) يعنى من الاخر السطر ده : Cancel = True مالوش أي تأثير والمفروض ينحذف كمان استخدام : DoCmd.SetWarnings False مالوش أى لزوم هنا لانه بيستخدم مع الاستعلامات لمنع الرسائل الافتراضية فقط والرد الشافى فى النقطة دى المعامل الثالث (Default) هو النص الافتراضي داخل مربع الإدخال فيه احتمالين للمشكلة مع 32 بت الاول : الهوك بيشتغل لحظة إنشاء النافذة وجود نص افتراضي (Default) يخلي الكنترول يتعمل له تهيئة بطريقة مختلفة النتيجة: الـ Password masking (*) ما يتطبقش أو يحصل خلل الثانى : اختلاف داخلي في الـ : InputBox (32 بت مقابل 64 بت) الـ Edit control ID (&H1324) بيتأثر بوجود Default Text مع النواة 32 او مع احد الاصدارات والنتيجة : EM_SETPASSWORDCHAR ممكن تروح لعنصر غلط أو تفشل طيب السؤال الان هل الحل ده صح و جذرى: InputBoxDK("Password required to proceed.", str_Title) من حيث الصحة : جزئيا صح ولكن مش جذرى ومش احترافى ومش الأصح طيب إيه الحل الصح : strAdminPWord = InputBoxDK("Password required to proceed.", str_Title, "") وبعد ان قمنا بالتفنيد والرد المناسب واللى ماله علاقة اساسا بالمشكلة مناط السؤال المشكلة الحقيقية تكمن فى خلل بقاعدة البيانات المرفقه نفسها لو عملت قاعدة جديدة وقمت باستيراد العناصر ( النماذج والوحدة النمطية العامة ) تقريبا سوف تنحل مشكلتك والسبب فى الصورة التالية من قاعدتك أكود لعناصر شبحية تم حذفها ولكن مازالت عالقة بالقاعدة