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

اما فكرتي هذه ......... وهي حتى الان غير قابلة للنشر ..... 💡 نظام متكامل لإدارة صلاحيات المستخدمين في Microsoft Access يهدف هذا البرنامج إلى توفير تحكم كامل ومرن في صلاحيات المستخدمين داخل قاعدة بيانات Access، بحيث يتم تخصيص الصلاحيات على مستوى النماذج والأزرار بشكل دقيق، مما يعزز الأمان وسهولة الاستخدام. 🔐 أولاً: إدارة صلاحيات النماذج يوفر النظام إمكانية التحكم في صلاحيات المستخدم لكل نموذج على حدة، وتشمل: ➕ إضافة بيانات (Add) ✏️ تعديل بيانات (Edit) ❌ حذف بيانات (Delete) حيث يمكن تحديد ما إذا كان المستخدم: يملك صلاحيات كاملة أو صلاحيات محدودة (عرض فقط أو إضافة بدون تعديل… إلخ) 🎛️ ثانياً: التحكم في الأزرار داخل النماذج يتميز النظام بإدارة ذكية لواجهة المستخدم من خلال: إظهار الأزرار المصرح بها فقط حسب صلاحيات المستخدم إخفاء الأزرار غير المسموح بها تلقائيًا إعادة ترتيب الأزرار ديناميكيًا بحيث: لا تظهر أي فراغات يتم عرض الأزرار بشكل متتالي ومنظم الحفاظ على الشكل الجمالي للنموذج 🎨 ثالثاً: تخصيص واجهة المستخدم يوفر البرنامج مرونة عالية في تخصيص الواجهة، مثل: ✍️ التحكم في مسميات الأزرار بسهولة 🖼️ تغيير أيقونات الأزرار 🏠 تخصيص الشاشة الرئيسية: أسماء العناصر الأيقونات ترتيب العرض وذلك بدون الحاجة لتعديل الكود، بل من خلال جداول إعدادات مخصصة. ⚙️ رابعاً: مميزات إضافية نظام يعتمد على مستويات المستخدمين (User Levels / Groups) سهولة التوسع وإضافة صلاحيات جديدة إمكانية ربط الصلاحيات بجداول لسهولة الإدارة واجهة ديناميكية تتكيف مع كل مستخدم تلقائيًا 🔐 خامساً: إدارة كلمات المرور واستعادتها يدعم النظام آليات متقدمة لإدارة حسابات المستخدمين، مما يعزز مستوى الأمان وسهولة الاستخدام، وتشمل: 📧 استعادة كلمة المرور عبر البريد الإلكتروني إمكانية استرجاع كلمة المرور في حال نسيانها إرسال رابط أو رمز تحقق (OTP) إلى البريد الإلكتروني الخاص بالمستخدم التحقق من هوية المستخدم قبل إعادة تعيين كلمة المرور ضمان حماية الحساب من الوصول غير المصرح به 🔄 تغيير كلمة المرور تمكين المستخدم من تغيير كلمة المرور الخاصة به في أي وقت التحقق من كلمة المرور الحالية قبل التغيير تطبيق سياسات أمان (مثل الحد الأدنى لطول كلمة المرور أو تعقيدها) حفظ كلمة المرور بشكل آمن (مشفّر) داخل قاعدة البيانات 🚀 الخلاصة هذا النظام يوفر بيئة عمل احترافية داخل Access من خلال: تعزيز الأمان تحسين تجربة المستخدم تقليل الأخطاء توفير واجهة مرنة وقابلة للتخصيص بالكامل القيديو يلخص ذلك :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

فقط للمشاركة مع النخبة تفضل اساذ @ابوخليل محاولتي المتواضعة . حسب ما فهمت وزودت شويه من عندي .... BoKhalil.rar

السادة الزملاء : مرفق دالة التفقيط بدون اكواد كل ما عليك ان تدرج الشيت المرفق فى اى ملف اكسيل تريد تفعيل دالة التفقيط بدون اكواد ولو نسخة الاكسيل 2021 فيما فوق يتم استخدام دالة مخصصة اسمها tafkeet Tafqeet_Dynamic_System (1).xlsx

وعليكم السلام ورحمة الله وبركاته خلينا نتكلم بصراحة ومن غير أي تجميل اللي بيحصل دلوقتي مش تراجع منتدى اللي بيحصل إن طريقة التعلم نفسها اتغيرت وفي ناس لسه مصممة تتعامل بعقلية زمن فات زمان… اللي عنده معلومة كان مصدر قوة دلوقتي… نفس المعلومة بقت متاحة لأي حد في ثواني فالسؤال الحقيقي بقى: إيه القيمة الفعلية للخبير انهارده؟ هل:يكتب الكود من الصفر؟ واللا: يفهم، يراجع، ويصحح اللي بيتولد قدامه؟ خلينا نبقى أوضح دلوقتي فيه نوعين: مستخدم أدوات: ينسخ من AI يجرب لو اشتغل خلاص مطور فاهم يبص على نفس الكود ويقول: ده غلط ليه و ده خطر فين وامتى ينهار الحقيقة اللي ممكن تضايق البعض: فيه ناس كانت قيمتها إنها "تعرف الحل" النهارده الحل بقى متاح للجميع فلو القيمة ما اتطورتش طبيعي إنها تقل طيب هل AI بديل للخبراء؟ الإجابة قطعا و ببساطة: لا AI لا يفهم النظام بل هو فقط يتوقع و لكن لا يشغل الكود و لا يرى النتائج و لا يختبر الحالات الشاذة و لا يعيش بيئة أكسس بكل مشاكلها هو فقط يقول: ده شكل كود غالبا بيشتغل وهنا الخدعة الخطيرة الكلام الناتج منه ظاهريا تجده : منظم واثق و مقنع فيتكون انطباع عند البعض إنه "فاهم" لكن الحقيقة: دي بلاغة لغوية مش خبرة تنفيذية: لانه مجرد وفقط الة تقليد لغوي ليست مفسركود بل مولد نصوص احتمالي متى يضللك فعلا؟ لما تديله Bug خفي Edge Case أو سلوك غير موثق في أكسس ساعتها: يخترع تفسير منطقي شكله صح ظاهريا لكنه فعليا غلط فتدخل في دايرة: تجرب → تكتشف خطأ → تصلح → يبوظ تاني وهنا المفارقة أحيانا AI: لا يوفر وقت بل يضاعف وقت التصحيح بينما لما تكتب بإيدك: ممكن تغلط لكنك تفهم لماذا في أكسس تحديدا… المشكلة أكبر لأنه مليان سلوكيات غير موثقة فيه تفاعلات غريبة مع API فيه Edge Cases غير متوقعة وأدوات AI: لا تعيش هذه البيئة و لا تختبرها و لا تعرف حدودها لكنها تتكلم بثقة بلاغية فقط الخلاصة بدون مجاملة اللي فاهم → AI هيقويه اللي مش فاهم → AI هيغرقه تعامل مع AI كـ: مرجع سريع و مساعد مش: مصدر نهائي ولا عقل بديل الاعتماد الأعمى → كارثة الاستخدام الواعي → قوة

بارك الله فيك اخي والحقيقة كان كلامك في البداية في محله ونسأل الله الهداية اما عن سؤالك سأقوم بتجزئته إلى جزئين (التوقعات بشأن قواعد بيانات أكسس كإطار عمل) و (التوقعات بشأنه مع تطور الذكاء الصناعي) فيما يخص الجزء الأول من السؤال فبالمناسبة دائما ما يُسأل لي وتكون إجابتي غلى شكل مثال كالتالي تخيل أن لدينا سيارة نقل صغيرة ذات 4 عجلات وشاحنة نقل كبيرة ذات إثنا عشرة عجلة وانت صاحب بقالة صغيرة وأغلب عملك اليومي يقتصر على توريد بضاعة صغيرة (كرتون واحد من كذا صنف مثلاً) فهل سيكون من الأجدى لك إستئجار السيارة الصغيرة أم الشاحنة الكبيرة؟ وهذا هو الحال مع قواعد البيانات (أو بالأصح مع البرامج والتطبيقات الخاصة بقواعد البيانات) حيث سيكون من الأجدى لأصحاب المشاريع الصغيرة إستخدام تطبيق تم تطويره بإستخدام أكسس لأكثر من سبب منها على سبيل المثال لا الحصر: - غالبا من يبدأ بتأسيس المشاريع الصغيرة يكونون من الشباب رواد الاعمال وهذا يعني أنه من الوارد أن يتم تعديل آليات العمل أكثر من مرة حتى يتم التوصل إلى آلية عمل شبه ثابتة ومن هذا المنطلق فأيهما سيكون الأرخص والأكثر مرونة أن يتم تنفيذ التعديل بإستخدام أكسس أم بإستخدام أحد البرامج الكبيرة الأخرى؟ - وحتى لو قلنا أن هذا المشروع قد أنشئ بعد دراسة كافية ووافية ولن يتطلب أي تعديلات (والذي من واقع خبرتي أراه شبه مستحيل) فهل سيتطلب حجم البيانات لمشروع صغير يعمل فيه عشرة موظفين وحجم تعاملاته لاتتجاوز مائة أو مائتين الف دولار شهريا لبرنامج وقاعدة بيانات سيكلف المشروع الاف الدولارات للدعم الفني فقط؟ - أهم مايميز اكسس هو أنها بيئة قواعد بيانات علائقية وهذا يعني أن أسلوب تصميم وبناء قاعدة البيانات فيه هو نفس الأسلوب لتصميم وبناء قواعد البيانات في أي بيئة أخرى وهكذا فعندما يكبر حجم المشروع سيكون من السهل نقل (هجرة) البيانات إلى أي قاعدة بيانات أخرى - في الاونة الاخيرة بدأت مايكروسوفت ببعض الاضافات والتحسينات كما رأينا في إضافة كائن عنصر تحكم متصفح Edge او تحديث عنصر تحكم الرسوم البيانية وكذا محرر الاستعلامات موناكو وغيرها من الاضافات والتحسينات التي سيتم اضافتها في المستقبل وأعتقد أن مايكروسوفت لم تقم بهذه التحديثات إلا على ضوء نتائج دراسة للسوق قامت بها وجعلها تستشعر أهمية هذا التطبيق من أوفيس (المظلوم من حيث التحديثات مقارنة ببقية تطبيقات أوفيس الأخرى) وهذا إن دل على شيئ فإنما يدل على أن هناك توجه كبير نحو العمل بإستخدام أكسس في المستقبل. وفيما يخص الجزء الثاني من السؤال (التوقعات بشأنه مع تطور الذكاء الصناعي) فوجهة نظري أن المبالغة في إستخدامه لن يفيد أحد - الغير فاهم سيخاطر بإستخدام برنامج لايعلم إن كان صحيحاً أم مليئا بالأخطاء والأخطار التي قد يتسبب بها على المدى القريب او البعيد - المبتدئ الذي يريد التعلم لن يتعلم شيئاً فمن خلال رحلة تعلمي لم أجد أفضل طرق للتعلم إلا شيئ واحد هو التجربة والخطأ فإذا لم يمارس المبتدئ العمل بنفسه ويظل يجرب ويخطئ فلن يتعلم أي شيئ - المحترف لابأس في أن يستخدم الذكاء الصناعي للمساعدة في حل جزئية معينة (جزئية وليس الكل) كذلك يمكن إستخدامه للمساعدة في تصور شكل النماذج والتقارير أو إقتراح الخطوط العريضة للبرنامج لإستخدامها للعصف الذهني لإستنباط الأفكار فقط أما أن يستخدمه في إنشاء برنامج من الألف إلى الياء فهذا أنا ضده تماماً. فكما يعلم الجميع فأن كتابة البرنامج من الصفر أسهل من مراجعة برنامج قام به شخص آخر والشيئ الثاني أن قيام المطور بكتابة الكود بنفسه يجعله ملماً بأدق تفاصيله وعند حدوث أي خطأ يكون من السهل معرفة موقعه ومعرفة تأثير التعديل الذي سيتم على الكود لإصلاح الخطأ على بقية الأكواد وحتى ولو إفترضنا جدلاً أن الذكاء الصناعي قام بإنشاء تطبيق صحيح 100% (سواء كان أكسس أو غيره) فهل سيتمكن المطور من حل أي مشكلة قد تظهر في المستقبل؟ وإذا كان يعمل ولم تظهر أخطاء فهل سيكون لدى المطور الذي سيدّعي القيام بالعمل الثقة الكافية فيه أم سيظل حاطط يده على قلبه في إنتظار المكالمة التي تخبره بظهور خطأ ... والا أنتو إيه رأيكو 😅؟

السلام عليكم في كثير من الاوقات ما نعرف نستعمل الفاصلة او الفاصلة المنقوطة !! هي جزء من اعدادات الوندوز في المرفق وحدة نمطية تقوم بجلب الفاصل ، ونستعملها كالتالي: debug.print fList_Seperator او dim fList as string fList=fList_Seperator stDocName = "tbl_student1" & DLookup("Year_name" & fList & "tbl_basic") وانا اقوم بعمل الكثير من ملفات csv ، فحتى الكود يتوافق بين جهازي وبين اجهزة جميع المستخدمين وبغض النظر عن اعدادات الوندوز لهم ، استعمل هذا الكود لحل هذه الحالات Period_or_Semi_Period.zip

،، جرب اجعل المعادلات في :- J2 = =IFERROR(IF(INDEX(Q:Q, MATCH(B5, P:P, 0)) = H2, "P", ""), "") J3 = =IFERROR(IF(INDEX(Q:Q, MATCH(B5, P:P, 0)) = H3, "P", ""), "") J4 = =IFERROR(IF(INDEX(Q:Q, MATCH(B5, P:P, 0)) = H4, "P", ""), "") وعدل الخلية B5 لتصبح :- =IFERROR(IF(MATCH(INDEX(data!$P$2:$P$23, MATCH($E$1, data!$R$2:$R$23, 0)), $P$2:$P$13, 0), INDEX(data!$P$2:$P$23, MATCH($E$1, data!$R$2:$R$23, 0)), ""), "") لتلافي الخروج عن نطاق P2 - P13

وعليكم السلام -كان عليك ان تقوم بالتالى حدد العمود. اذهب إلى علامة التبويب بيانات (Data) > نص إلى أعمدة (Text to Columns) > إنهاء (Finish) ثم اكتب معادلة جمع عادية وستحصل على النتيجة المرجوة تقرير التأخير الشهري 11112.xlsx

اعرض الملف UiMsg Framework - نظام رسائل احترافي استبدال صندوق الرسائل فى الاكسس بنموذج رسائل احترافى بسطر واحد بس كل حاجة جاهزة مش محتاج تفكر في تصميم نموذج مش محتاج نموذج الرسائل يكون موجود اساسا مش محتاج تكتب كود كبير بعد كده لصندوق الرسائل استدعي الدالة وخلاص والنظام يعمل كل شئ النظام يقدم 4 أنواع رسائل جاهزة : { معلومة - نجاح - تحذير - خطأ } كل نوع بتصميمه ولونه وأيقونته معلومة : من خلال : UiInfo اللون : أزرق نجاح : من خلال : UiSuccess اللون : أخضر تحذير : من خلال : UiWarning اللون : برتقالي خطأ : من خلال : UiError اللون : أحمر 3 أنواع إدخال : { نص حر - رقم مع تحقق تلقائي - اختيار من قائمة } نص حر : من خلال : UiInput رقم مع تحقق تلقائي: من خلال : UiInputNum يرفض الحروف بدون ما تكتب سطر واحد اختيار من قائمة : من خلال : UiPick قرارات متعددة : { تأكيد نعم/لا - ثلاثة خيارات أزرار مخصصة بأسماء ترجعها النتيجة مباشرة } نعم / لا : من خلال : BlnUiConfirm يرجع True أو False مباشرة ثلاثة خيارات : من خلال :IntUiConfirm3 يرجع 1 أو 2 أو 0 أزرار مخصصة : من خلال :UiCustom يرجع اسم الزر اللي اتضغط مش رقمه دعم كامل للعربية والإنجليزية : { اتجاه النص RTL/LTR تلقائي - الأزرار والعناوين بالغتين من خلال معامل UiLangEn يكفي لتبديل كل شيء } أضف UiLangEn كآخر parameter وكل شيء يتبدل : اتجاه النص - الأزرار - العناوين الافتراضية ثيم موحد قابل للتخصيص : { ألوان الهيدر والأيقونات والأزرار كلها من UiTheme غير لون الـ Accent في مكان واحد وكل الرسائل تتغير } كل ألوان النظام مجمعة في UiTheme مناسب لأي مشروع قاعدة بيانات صغير أو كبير - عربي أو إنجليزي - مبتدئ أو محترف يبني نفسه : لا تثبيت ولا إعداد كل إجراء أو وظيفة واضحة الاسم - واضحة الـ return - واضحة الاستخدام اسم الوحدة النمطية : modUIMsgFramework كود الوحدة النمطية.. Option Explicit Option Compare Database Public Enum UiIcon UiIconInfo = 0 UiIconSuccess = 1 UiIconWarning = 2 UiIconError = 3 UiIconQuestion = 4 End Enum Public Enum UiMode UiModeAlert = 0 UiModeInput = 1 UiModeNumber = 2 UiModeList = 3 End Enum Public Enum UiLang UiLangAr = 0 UiLangEn = 1 End Enum Public Type UiParams strMessage As String strTitle As String strButtons As String strDefault As String strList As String strDetails As String strResult As String enuIcon As UiIcon enuMode As UiMode enuLang As UiLang End Type Public Type UiTheme lngAccent As Long lngHeader As Long lngBg As Long lngText As Long lngMuted As Long lngBorder As Long lngSuccess As Long lngWarning As Long lngError As Long lngInfo As Long lngQuestion As Long End Type Private Const STRFORMNAME As String = "frmUiMsg" Private Const STRMODNAME As String = "modUICore" Private Const MAX_BUTTONS As Integer = 5 Private Const FRM_W As Long = 9000 Private m_typParams As UiParams Public Function TypDefaultTheme() As UiTheme Dim typT As UiTheme typT.lngAccent = RGB(0, 120, 212) typT.lngHeader = RGB(32, 32, 38) typT.lngBg = RGB(245, 246, 250) typT.lngText = RGB(30, 30, 35) typT.lngMuted = RGB(120, 120, 130) typT.lngBorder = RGB(210, 212, 220) typT.lngSuccess = RGB(16, 124, 16) typT.lngWarning = RGB(200, 100, 0) typT.lngError = RGB(196, 43, 28) typT.lngInfo = RGB(0, 120, 212) typT.lngQuestion = RGB(104, 33, 122) TypDefaultTheme = typT End Function Private Function BlnFormExists(ByVal strName As String) As Boolean On Error Resume Next Dim objFrm As Object Set objFrm = CurrentProject.AllForms(strName) BlnFormExists = Not (objFrm Is Nothing) Set objFrm = Nothing On Error GoTo 0 End Function Private Sub LogError(ByVal strProc As String, _ ByVal lngNum As Long, _ ByVal strDesc As String) Debug.Print "[" & STRMODNAME & "." & strProc & "] " & _ "Err " & lngNum & ": " & strDesc & _ " @ " & Now() End Sub Public Function TypGetParams() As UiParams TypGetParams = m_typParams End Function Public Sub SetResult(ByVal strResult As String) m_typParams.strResult = strResult End Sub Private Sub ResetParams() Dim typEmpty As UiParams m_typParams = typEmpty End Sub Private Function StrDefaultTitle(ByVal enuIcon As UiIcon, _ ByVal enuLang As UiLang) As String If enuLang = UiLangAr Then Select Case enuIcon Case UiIconSuccess: StrDefaultTitle = "تم بنجاح" Case UiIconWarning: StrDefaultTitle = "تحذير" Case UiIconError: StrDefaultTitle = "خطأ" Case UiIconQuestion: StrDefaultTitle = "تأكيد" Case Else: StrDefaultTitle = "معلومة" End Select Else Select Case enuIcon Case UiIconSuccess: StrDefaultTitle = "Success" Case UiIconWarning: StrDefaultTitle = "Warning" Case UiIconError: StrDefaultTitle = "Error" Case UiIconQuestion: StrDefaultTitle = "Confirm" Case Else: StrDefaultTitle = "Information" End Select End If End Function Private Function StrValidateButtons(ByVal strBtns As String) As String Dim arrB() As String Dim intCnt As Integer Dim intI As Integer Dim strOut As String arrB = Split(strBtns, ",") intCnt = UBound(arrB) + 1 If intCnt > MAX_BUTTONS Then LogError "StrValidateButtons", 0, _ "تجاوز الحد الأقصى للأزرار (" & intCnt & "). سيتم اقتصارها على " & MAX_BUTTONS intCnt = MAX_BUTTONS End If For intI = 0 To intCnt - 1 If Len(strOut) > 0 Then strOut = strOut & "," strOut = strOut & Trim(arrB(intI)) Next intI StrValidateButtons = strOut End Function Private Function BlnBuildMsgForm() As Boolean On Error GoTo ErrHandler Dim typT As UiTheme Dim objFrm As Object Dim objCtl As Object Dim strTemp As String Dim intI As Integer Dim lngLeft As Long typT = TypDefaultTheme() Const HDR_H As Long = 900 Const ICON_L As Long = 200 Const ICON_T As Long = 150 Const ICON_W As Long = 600 Const ICON_H As Long = 600 Const TITLE_L As Long = 900 Const TITLE_T As Long = 200 Const TITLE_W As Long = 7800 Const TITLE_H As Long = 500 Const MSG_L As Long = 300 Const MSG_T As Long = 1050 Const MSG_W As Long = 8400 Const MSG_H As Long = 1400 Const DET_L As Long = 300 Const DET_T As Long = 2500 Const DET_W As Long = 8400 Const DET_H As Long = 700 Const INP_L As Long = 300 Const INP_T As Long = 3300 Const INP_W As Long = 8400 Const INP_H As Long = 450 Const DIV_T As Long = 4050 Const BTN_T As Long = 4250 Const BTN_W As Long = 1550 Const BTN_H As Long = 550 Const FRM_H As Long = 5000 Set objFrm = CreateForm strTemp = objFrm.Name With objFrm .Caption = "" .ScrollBars = 0 .RecordSelectors = False .NavigationButtons = False .DividingLines = False .BorderStyle = 1 .AutoCenter = True .PopUp = True .Modal = True .Width = FRM_W .Section(0).Height = FRM_H .Section(0).BackColor = typT.lngBg End With Set objCtl = CreateControl(strTemp, acRectangle, acDetail) With objCtl .Name = "recHeader": .Left = 0: .Top = 0 .Width = FRM_W: .Height = HDR_H .BackColor = typT.lngHeader: .BackStyle = 1 .BorderStyle = 0: .SpecialEffect = 0 End With Set objCtl = CreateControl(strTemp, acRectangle, acDetail) With objCtl .Name = "recIcon": .Left = ICON_L: .Top = ICON_T .Width = ICON_W: .Height = ICON_H .BackColor = typT.lngInfo: .BackStyle = 1 .BorderStyle = 0: .SpecialEffect = 0 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblIcon": .Caption = "i" .Left = ICON_L: .Top = ICON_T .Width = ICON_W: .Height = ICON_H .FontSize = 20: .FontBold = True .ForeColor = vbWhite: .BackStyle = 0: .TextAlign = 2 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblTitle": .Caption = "" .Left = TITLE_L: .Top = TITLE_T .Width = TITLE_W: .Height = TITLE_H .FontSize = 14: .FontBold = True .ForeColor = vbWhite: .BackStyle = 0: .TextAlign = 1 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblMessage": .Caption = "" .Left = MSG_L: .Top = MSG_T .Width = MSG_W: .Height = MSG_H .FontSize = 11: .ForeColor = typT.lngText .BackStyle = 0: .TextAlign = 1 End With Set objCtl = CreateControl(strTemp, acLabel, acDetail) With objCtl .Name = "lblDetails": .Caption = "" .Left = DET_L: .Top = DET_T .Width = DET_W: .Height = DET_H .FontSize = 9: .ForeColor = typT.lngMuted .BackStyle = 0: .Visible = False End With Set objCtl = CreateControl(strTemp, acTextBox, acDetail) With objCtl .Name = "txtInput" .Left = INP_L: .Top = INP_T .Width = INP_W: .Height = INP_H .FontSize = 11 .BorderColor = typT.lngBorder: .BackColor = vbWhite .Visible = False End With Set objCtl = CreateControl(strTemp, acComboBox, acDetail) With objCtl .Name = "cboList" .Left = INP_L: .Top = INP_T .Width = INP_W: .Height = INP_H .FontSize = 11 .BorderColor = typT.lngBorder: .BackColor = vbWhite .RowSourceType = "Value List" .LimitToList = True: .AllowValueListEdits = False .Visible = False End With Set objCtl = CreateControl(strTemp, acLine, acDetail) With objCtl .Name = "linDivider": .Left = 0: .Top = DIV_T .Width = FRM_W: .Height = 0 .BorderColor = typT.lngBorder: .BorderWidth = 1 End With For intI = 1 To MAX_BUTTONS lngLeft = 200 + ((intI - 1) * 1760) Set objCtl = CreateControl(strTemp, acCommandButton, acDetail) With objCtl .Name = "btn" & intI: .Caption = "btn" & intI .Left = lngLeft: .Top = BTN_T .Width = BTN_W: .Height = BTN_H .FontSize = 10: .FontBold = True .BackColor = typT.lngAccent: .ForeColor = vbWhite .BorderStyle = 0: .Visible = False .OnClick = "=ProcBtnClick(" & intI & ")" End With Next intI DoCmd.Save acForm, strTemp DoCmd.Close acForm, strTemp, acSaveYes DoCmd.Rename STRFORMNAME, acForm, strTemp BlnBuildMsgForm = True Set objCtl = Nothing: Set objFrm = Nothing Exit Function ErrHandler: LogError "BlnBuildMsgForm", Err.Number, Err.Description BlnBuildMsgForm = False Set objCtl = Nothing: Set objFrm = Nothing End Function Private Function BlnInjectMsgCode() As Boolean On Error GoTo ErrHandler Dim objMdl As Object Dim strCode As String Dim strOldCode As String DoCmd.OpenForm STRFORMNAME, acDesign, , , , acHidden Set objMdl = Forms(STRFORMNAME).Module If objMdl.CountOfLines > 0 Then strOldCode = objMdl.Lines(1, objMdl.CountOfLines) objMdl.DeleteLines 1, objMdl.CountOfLines End If strCode = StrFormCodeHeader() & _ StrFormCodeApplyIcon() & _ StrFormCodeApplyLang() & _ StrFormCodeSetupBtns() & _ StrFormCodeFillList() & _ StrFormCodeOpen() & _ StrFormCodeBtn() & _ StrFormCodeUnload() objMdl.AddFromString strCode If objMdl.CountOfLines < 10 Then If Len(strOldCode) > 0 Then objMdl.DeleteLines 1, objMdl.CountOfLines objMdl.AddFromString strOldCode End If LogError "BlnInjectMsgCode", 0, "AddFromString أنتج كوداً فارغاً، تم استعادة الكود القديم" BlnInjectMsgCode = False GoTo Cleanup End If DoCmd.Save acForm, STRFORMNAME DoCmd.Close acForm, STRFORMNAME, acSaveYes BlnInjectMsgCode = True Cleanup: Set objMdl = Nothing Exit Function ErrHandler: LogError "BlnInjectMsgCode", Err.Number, Err.Description BlnInjectMsgCode = False Set objMdl = Nothing End Function Private Function StrFormCodeHeader() As String Dim s As String s = "Option Explicit" & vbCrLf s = s & "Option Compare Database" & vbCrLf & vbCrLf s = s & "Private mintMode As Integer" & vbCrLf s = s & "Private mintLang As Integer" & vbCrLf & vbCrLf StrFormCodeHeader = s End Function Private Function StrFormCodeApplyIcon() As String Dim s As String s = "Private Sub ProcApplyIcon(ByVal intIcon As Integer)" & vbCrLf s = s & " Select Case intIcon" & vbCrLf s = s & " Case 1" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(16,124,16)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(16,124,16)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(252)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case 2" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(200,100,0)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(200,100,0)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(56)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case 3" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(196,43,28)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(196,43,28)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(251)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case 4" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(104,33,122)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(104,33,122)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(63)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Wingdings""" & vbCrLf s = s & " Case Else" & vbCrLf s = s & " Me.recHeader.BackColor = RGB(0,120,212)" & vbCrLf s = s & " Me.recIcon.BackColor = RGB(0,120,212)" & vbCrLf s = s & " Me.lblIcon.Caption = Chr(105)" & vbCrLf s = s & " Me.lblIcon.FontName = ""Arial""" & vbCrLf s = s & " End Select" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeApplyIcon = s End Function Private Function StrFormCodeApplyLang() As String Dim s As String s = "Private Sub ProcApplyLang(ByVal intLang As Integer)" & vbCrLf s = s & " Dim intAlign As Integer" & vbCrLf s = s & " intAlign = IIf(intLang = 0, 3, 1)" & vbCrLf s = s & " Me.lblTitle.TextAlign = intAlign" & vbCrLf s = s & " Me.lblMessage.TextAlign = intAlign" & vbCrLf s = s & " Me.lblDetails.TextAlign = intAlign" & vbCrLf s = s & " Me.txtInput.TextAlign = intAlign" & vbCrLf s = s & " Me.cboList.TextAlign = intAlign" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeApplyLang = s End Function Private Function StrFormCodeSetupBtns() As String Dim s As String s = "Private Sub ProcSetupBtns(ByVal strBtns As String, ByVal intLang As Integer)" & vbCrLf s = s & " Dim arrBtns() As String" & vbCrLf s = s & " Dim intTotal As Integer" & vbCrLf s = s & " Dim intI As Integer" & vbCrLf s = s & " Dim lngBtnW As Long" & vbCrLf s = s & " Dim lngBtnH As Long" & vbCrLf s = s & " Dim lngGap As Long" & vbCrLf s = s & " Dim lngTotalW As Long" & vbCrLf s = s & " Dim lngStartX As Long" & vbCrLf s = s & " Dim blnIsRtl As Boolean" & vbCrLf s = s & " arrBtns = Split(strBtns, "","")" & vbCrLf s = s & " intTotal = UBound(arrBtns) + 1" & vbCrLf s = s & " If intTotal > 5 Then intTotal = 5" & vbCrLf s = s & " blnIsRtl = (intLang = 0)" & vbCrLf s = s & " lngBtnW = 1550" & vbCrLf s = s & " lngBtnH = 550" & vbCrLf s = s & " lngGap = 200" & vbCrLf s = s & " lngTotalW = (intTotal * lngBtnW) + ((intTotal - 1) * lngGap)" & vbCrLf s = s & " lngStartX = (Me.Width - lngTotalW) \ 2" & vbCrLf s = s & " For intI = 1 To 5" & vbCrLf s = s & " Me(""btn"" & intI).Visible = False" & vbCrLf s = s & " Next intI" & vbCrLf s = s & " For intI = 1 To intTotal" & vbCrLf s = s & " With Me(""btn"" & intI)" & vbCrLf s = s & " .Caption = Trim(arrBtns(intI - 1))" & vbCrLf s = s & " If blnIsRtl Then" & vbCrLf s = s & " .Left = lngStartX + ((intTotal - intI) * (lngBtnW + lngGap))" & vbCrLf s = s & " Else" & vbCrLf s = s & " .Left = lngStartX + ((intI - 1) * (lngBtnW + lngGap))" & vbCrLf s = s & " End If" & vbCrLf s = s & " .Top = 4250: .Width = lngBtnW: .Height = lngBtnH" & vbCrLf s = s & " .Visible = True" & vbCrLf s = s & " End With" & vbCrLf s = s & " Next intI" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeSetupBtns = s End Function Private Function StrFormCodeFillList() As String Dim s As String s = "Private Sub ProcFillList(ByVal strItems As String, ByVal strDefault As String)" & vbCrLf s = s & " Dim arrItems() As String" & vbCrLf s = s & " Dim strSource As String" & vbCrLf s = s & " Dim intI As Integer" & vbCrLf s = s & " arrItems = Split(strItems, "","")" & vbCrLf s = s & " For intI = 0 To UBound(arrItems)" & vbCrLf s = s & " strSource = strSource & Trim(arrItems(intI)) & "";""" & vbCrLf s = s & " Next intI" & vbCrLf s = s & " Me.cboList.RowSource = strSource" & vbCrLf s = s & " If Len(Trim(strDefault)) > 0 Then" & vbCrLf s = s & " Me.cboList.Value = strDefault" & vbCrLf s = s & " ElseIf UBound(arrItems) >= 0 Then" & vbCrLf s = s & " Me.cboList.Value = Trim(arrItems(0))" & vbCrLf s = s & " End If" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeFillList = s End Function Private Function StrFormCodeOpen() As String Dim s As String s = "Private Sub Form_Open(Cancel As Integer)" & vbCrLf s = s & " On Error GoTo ErrHandler" & vbCrLf s = s & " Dim typP As UiParams" & vbCrLf s = s & " typP = TypGetParams()" & vbCrLf s = s & " mintMode = CInt(typP.enuMode)" & vbCrLf s = s & " mintLang = CInt(typP.enuLang)" & vbCrLf s = s & " Me.Caption = typP.strTitle" & vbCrLf s = s & " Me.lblTitle.Caption = typP.strTitle" & vbCrLf s = s & " Me.lblMessage.Caption = typP.strMessage" & vbCrLf s = s & " Me.lblDetails.Visible = (Len(Trim(typP.strDetails)) > 0)" & vbCrLf s = s & " If Me.lblDetails.Visible Then Me.lblDetails.Caption = typP.strDetails" & vbCrLf s = s & " ProcApplyIcon CInt(typP.enuIcon)" & vbCrLf s = s & " ProcApplyLang mintLang" & vbCrLf s = s & " ProcSetupBtns typP.strButtons, mintLang" & vbCrLf s = s & " Me.txtInput.Visible = (mintMode = 1 Or mintMode = 2)" & vbCrLf s = s & " Me.cboList.Visible = (mintMode = 3)" & vbCrLf s = s & " If mintMode = 1 Or mintMode = 2 Then" & vbCrLf s = s & " Me.txtInput.Value = typP.strDefault" & vbCrLf s = s & " Me.txtInput.SetFocus" & vbCrLf s = s & " End If" & vbCrLf s = s & " If mintMode = 3 Then" & vbCrLf s = s & " ProcFillList typP.strList, typP.strDefault" & vbCrLf s = s & " Me.cboList.SetFocus" & vbCrLf s = s & " End If" & vbCrLf s = s & " Exit Sub" & vbCrLf s = s & "ErrHandler:" & vbCrLf s = s & " Debug.Print ""Form_Open Err: "" & Err.Number & "" - "" & Err.Description" & vbCrLf s = s & " DoCmd.Close acForm, Me.Name" & vbCrLf s = s & "End Sub" & vbCrLf & vbCrLf StrFormCodeOpen = s End Function Private Function StrFormCodeBtn() As String Dim s As String s = "Public Function ProcBtnClick(ByVal intNum As Integer)" & vbCrLf s = s & " On Error GoTo ErrHandler" & vbCrLf s = s & " Dim strResult As String" & vbCrLf s = s & " Dim strWarn As String" & vbCrLf s = s & " Select Case mintMode" & vbCrLf s = s & " Case 1" & vbCrLf s = s & " If intNum = 1 Then" & vbCrLf s = s & " strResult = Nz(Me.txtInput.Value, """")" & vbCrLf s = s & " Else" & vbCrLf s = s & " strResult = ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & " Case 2" & vbCrLf s = s & " If intNum = 1 Then" & vbCrLf s = s & " If Len(Nz(Me.txtInput.Value, """")) > 0 Then" & vbCrLf s = s & " If Not IsNumeric(Me.txtInput.Value) Then" & vbCrLf s = s & " strWarn = IIf(mintLang = 0, ""أدخل رقماً صحيحاً"", ""Enter a valid number"")" & vbCrLf s = s & " MsgBox strWarn, vbExclamation" & vbCrLf s = s & " Me.txtInput.SetFocus" & vbCrLf s = s & " Exit Function" & vbCrLf s = s & " End If" & vbCrLf s = s & " End If" & vbCrLf s = s & " strResult = Nz(Me.txtInput.Value, """")" & vbCrLf s = s & " Else" & vbCrLf s = s & " strResult = ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & " Case 3" & vbCrLf s = s & " If intNum = 1 Then" & vbCrLf s = s & " strResult = Nz(Me.cboList.Value, """")" & vbCrLf s = s & " Else" & vbCrLf s = s & " strResult = ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & " Case Else" & vbCrLf s = s & " strResult = Me(""btn"" & intNum).Caption" & vbCrLf s = s & " End Select" & vbCrLf s = s & " SetResult strResult" & vbCrLf s = s & " DoCmd.Close acForm, Me.Name" & vbCrLf s = s & " Exit Function" & vbCrLf s = s & "ErrHandler:" & vbCrLf s = s & " Debug.Print ""ProcBtnClick Err: "" & Err.Number & "" - "" & Err.Description" & vbCrLf s = s & "End Function" & vbCrLf & vbCrLf StrFormCodeBtn = s End Function Private Function StrFormCodeUnload() As String Dim s As String s = "Private Sub Form_Unload(Cancel As Integer)" & vbCrLf s = s & " Dim typP As UiParams" & vbCrLf s = s & " typP = TypGetParams()" & vbCrLf s = s & " If Len(Nz(typP.strResult, """")) = 0 Then" & vbCrLf s = s & " SetResult ""__CANCEL__""" & vbCrLf s = s & " End If" & vbCrLf s = s & "End Sub" & vbCrLf StrFormCodeUnload = s End Function Private Function BlnEnsureForm() As Boolean On Error GoTo ErrHandler If BlnFormExists(STRFORMNAME) Then BlnEnsureForm = True Exit Function End If If Not BlnBuildMsgForm() Then LogError "BlnEnsureForm", 0, "BlnBuildMsgForm failed" Exit Function End If If Not BlnInjectMsgCode() Then LogError "BlnEnsureForm", 0, "BlnInjectMsgCode failed" Exit Function End If BlnEnsureForm = True Exit Function ErrHandler: LogError "BlnEnsureForm", Err.Number, Err.Description BlnEnsureForm = False End Function Private Function StrShowMsg(ByVal strMsg As String, _ ByVal enuIcon As UiIcon, _ ByVal strBtns As String, _ ByVal strTitle As String, _ ByVal enuMode As UiMode, _ ByVal strDef As String, _ ByVal strList As String, _ ByVal strDet As String, _ ByVal enuLang As UiLang) As String On Error GoTo ErrHandler If Not BlnEnsureForm() Then LogError "StrShowMsg", 0, "EnsureForm failed" StrShowMsg = "__CANCEL__" Exit Function End If If Len(Trim(strTitle)) = 0 Then strTitle = StrDefaultTitle(enuIcon, enuLang) End If ResetParams With m_typParams .strMessage = strMsg .strTitle = strTitle .strButtons = StrValidateButtons(strBtns) .enuIcon = enuIcon .enuMode = enuMode .strDefault = strDef .strList = strList .strDetails = strDet .enuLang = enuLang .strResult = "" End With DoCmd.OpenForm STRFORMNAME, acNormal, , , , acDialog StrShowMsg = m_typParams.strResult If Len(StrShowMsg) = 0 Then StrShowMsg = "__CANCEL__" ResetParams Exit Function ErrHandler: LogError "StrShowMsg", Err.Number, Err.Description ResetParams StrShowMsg = "__CANCEL__" End Function Public Sub UiInfo(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconInfo, strBtns, strTitle, UiModeAlert, "", "", "", enuLang End Sub Public Sub UiSuccess(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconSuccess, strBtns, strTitle, UiModeAlert, "", "", "", enuLang End Sub Public Sub UiWarning(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconWarning, strBtns, strTitle, UiModeAlert, "", "", "", enuLang End Sub Public Sub UiError(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDetails As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) Dim strBtns As String strBtns = IIf(enuLang = UiLangAr, "موافق", "OK") StrShowMsg strMsg, UiIconError, strBtns, strTitle, UiModeAlert, "", "", strDetails, enuLang End Sub Public Function BlnUiConfirm(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As Boolean Dim strBtns As String Dim strYes As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "نعم,لا", "Yes,No") strYes = IIf(enuLang = UiLangAr, "نعم", "Yes") strResult = StrShowMsg(strMsg, UiIconQuestion, strBtns, strTitle, UiModeAlert, "", "", "", enuLang) BlnUiConfirm = (strResult = strYes) End Function Public Function IntUiConfirm3(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As Integer Dim strBtns As String Dim strYes As String Dim strNo As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "نعم,لا,إلغاء", "Yes,No,Cancel") strYes = IIf(enuLang = UiLangAr, "نعم", "Yes") strNo = IIf(enuLang = UiLangAr, "لا", "No") strResult = StrShowMsg(strMsg, UiIconQuestion, strBtns, strTitle, UiModeAlert, "", "", "", enuLang) Select Case strResult Case strYes: IntUiConfirm3 = 1 Case strNo: IntUiConfirm3 = 2 Case Else: IntUiConfirm3 = 0 End Select End Function Public Function UiInput(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDefault As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strBtns As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "موافق,إلغاء", "OK,Cancel") strResult = StrShowMsg(strMsg, UiIconInfo, strBtns, strTitle, UiModeInput, strDefault, "", "", enuLang) UiInput = IIf(strResult = "__CANCEL__", "", strResult) End Function Public Function UiInputNum(ByVal strMsg As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDefault As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strBtns As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "موافق,إلغاء", "OK,Cancel") strResult = StrShowMsg(strMsg, UiIconInfo, strBtns, strTitle, UiModeNumber, strDefault, "", "", enuLang) Select Case strResult Case "__CANCEL__", "": UiInputNum = "" Case Else UiInputNum = IIf(IsNumeric(strResult), strResult, "") End Select End Function Public Function UiPick(ByVal strMsg As String, _ ByVal strItems As String, _ Optional ByVal strTitle As String = "", _ Optional ByVal strDefault As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strBtns As String Dim strResult As String strBtns = IIf(enuLang = UiLangAr, "موافق,إلغاء", "OK,Cancel") strResult = StrShowMsg(strMsg, UiIconQuestion, strBtns, strTitle, UiModeList, strDefault, strItems, "", enuLang) UiPick = IIf(strResult = "__CANCEL__", "", strResult) End Function Public Function UiCustom(ByVal strMsg As String, _ ByVal strBtns As String, _ Optional ByVal enuIcon As UiIcon = UiIconQuestion, _ Optional ByVal strTitle As String = "", _ Optional ByVal enuLang As UiLang = UiLangAr) As String Dim strResult As String strResult = StrShowMsg(strMsg, enuIcon, strBtns, strTitle, UiModeAlert, "", "", "", enuLang) UiCustom = IIf(strResult = "__CANCEL__", "", strResult) End Function ' ===================================== ' أمثلة الاستخدام ' ===================================== ' UiSuccess "تم انشاء النظام بنجاح" ' UiInfo "رسالة معلومة" ' UiWarning "تحذير: لا يمكن التراجع" ' UiError "حدث خطأ", "", "تفاصيل الخطأ" ' ' If BlnUiConfirm("هل تريد الحذف؟") Then ... ' ' Select Case IntUiConfirm3("حفظ التغييرات؟") ' Case 1: ' نعم ' Case 2: ' لا ' Case 0: ' إلغاء ' End Select ' ' Dim s As String ' s = StrUiInput("أدخل اسمك", "", "محمد") ' If Len(s) > 0 Then ... ' ' Dim n As String ' n = StrUiInputNum("أدخل العمر", "", "25") ' ' Dim pick As String ' pick = StrUiPick("اختر قسم", "مبيعات,محاسبة,مخازن,إدارة") ' ' Dim choice As String ' choice = StrUiCustom("اختر خيار", "حفظ,تجاهل,إلغاء") ' Select Case choice ' Case "حفظ": ... ' Case "تجاهل": ... ' Case "": ' أُغلق بدون اختيار ' End Select طريقة الاعداد و التشغيل : بعد اضافة الوحدة النمطية: modUIMsgFramework الى قاعدة بياناتك استدعي من أي زر أمر داخل أى نموذج أو من النافذة الفورية مباشرة UiSuccess "تم انشاء النظام بنجاح" للتجربة الفورية فى المرفق تم اضافة ما يلى : وحدة نمطية باسم : modBuildTestUI ماكرو باسم : BuildTestUI شغل الماكرو BuildTestUI على الفور هيتم عمل جدول tblEmployees يحتوى على بيانات افتراضية غير حقيقية للتجربة وهيتم عمل نموذج اختبار متكامل وفتحة بشكل مباشر صاحب الملف عسل قليل الدسم تمت الاضافه 04/29/26 الاقسام قسم الأكسيس  

اعرض الملف احصل على ألوان أكثر بهجة لنماذجك بإستخدام هذه الأداة {سلسلة الأدوات المساعدة المخصصة} 1.0.1 السلام عليكم ورحمة الله تعالى وبركاته استاذتى الكرام رواد المنتدى المحترمين اولا : بعد أذن استاذى الجليل ومعلمى القدير الاستاذ @منتصر الانسي --------------------------- قمت بتحميل مرفق للاستاذ منتصر جزاه الله عنا كل خير من هذا الموضوع الشيق : قمت بدراسة المرفق وتحليله بصراحة المرفق والفكرة أعجبت بهم كثيرا قمت بعمل القليل من التطوير ويتمثل هذا التطوير فى ....... طب ما تحملوا وشوفوا انتم بنفسكم وبعد إذن ستاذى الجليل قمت باقتباس الاسم والصورة من الموضوع الاصلى لان هذا المرفق هو إمتداد فقط للأفكار وها هى بضاعتكم نردها اليكم أحسن الله اليكم وشكر لكم وجزاكم عنى وعن كل طلاب العلم خيرا إن شاء الله استاذى الجليل : اتمنى أن تنال أفكارى المتواضعة استحسانكم ورضاكم صاحب الملف ابو جودي تمت الاضافه 04/21/26 الاقسام قسم الأكسيس  

اعرض الملف أداة إنشاء المخططات البيانية المخصصة {سلسلة الأدوات المساعدة المخصصة} اقدم لكم اليوم هذه الأداة البسيطة في تصميمها والرائعة في نتائجها في القيام بتمثيل البيانات بمخططات بيانية لإنشاء تقارير رسومية الحقيقة أن هذه الأداة ليست بكفاءة عنصر التحكم Chart ولكنها تؤدي أغلب النتائج المطلوبة في المخططات البيانية البسيطة التي على شكل أعمدة أو خطوط ولا تتطلب أي مهارات للعمل بها قمت بإرفاق ملف أكسس يحتوي على كل ما ستحتاجونه لفهم الأداة وطريقة إستخدامها والإستفادة منها في تطبيقاتكم أرجو أن تنال إستحسانكم وفي إنتظار أي ملاحظات أو أخطاء قد يجدها البعض تحياتي صاحب الملف منتصر الانسي تمت الاضافه 04/11/26 الاقسام قسم الأكسيس  

السلام عليكم بعد اذن استاذنا ابو مروان اليك تعديل زر الترحيل باستخدام المصفوفات Sub AddEmployee() Dim ws1 As Worksheet, ws2 As Worksheet Dim nextRow As Long, i As Long Dim srcRange As Variant Set ws1 = ThisWorkbook.Sheets("Sheet1") Set ws2 = ThisWorkbook.Sheets("Sheet2") If ws1.Range("I9").Value = "" Then MsgBox "يرجى إدخال اسم الموظف!", vbExclamation, "تنبيه" Exit Sub End If nextRow = ws2.Cells(ws2.Rows.Count, "C").End(xlUp).Row + 1 srcRange = Array("I5", "I7", "I9", "I11", "I13", "L11", "L13", "I15", "L15", _ "L5", "L7", "L9", "I19", "L19", "I21", "L21", "I23", "L23", _ "I25", "L25", "I28", "L28", "L30", "I33", "L33", "I35", "L35", _ "I37", "I40", "L40", "I44", "L44", "I46", "L46", "I48", "L48", _ "I50", "L50", "I52", "L52", "L55") For i = LBound(srcRange) To UBound(srcRange) ws2.Cells(nextRow, i + 1).Value = ws1.Range(srcRange(i)).Value Next i MsgBox "تمت إضافة الموظف بنجاح!", vbInformation, "نجاح" End Sub بسم الله.xlsm

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

تطور التعليم بالنسبة لي: وقبل ايام الانترنت ، في عمل المجسمات الثلاثية الابعاد 3D Animation كنت مشترك في مجلات شهرية تجيني من الخارج ، استفيد من الامثلة . الان لما اكون بحاجة الى مساعدة لكود معين: ارجع الى مساعد اكسس في الكود F1 وابحث فيه ، ابحث في المنتدى هذا ، وفي مواقع الانترنت ، استعين بالذكاء الاصطناعي ، وبالخصوص في مناقشة عمل مشروع جديد (يعني مو الكود). صحيح عدد الاسئلة في المنتدى صار اقل ، ولكني اقرأ عداد "عدد مرات قراءات الموضوع" ، وارى ان هناك كم كبير من الاعضاء الصامت ، الذي لايزال يقرأ مواضيع معينة. بمعنى ، انهم لا يسألون الكثير من الاسئلة ، لأن هناك طرق اخرى للحصول على اجابات ، ولكنهم يزورون المنتدى لمعرفة الطرق التي لا يلبيها الذكاء الاصطناعي. وللعلم ، فهناك على الاقل موقعين عالميين للاكسس تم اغلاقهم قريبا ، واعتقد الذكاء الاصطناعي له دور في الغلق ، وهتاك موقع ممنوع فيه استعمال الذكاء الاصطناعي في الاجابات ، وهو عامر الى الان. هي موجه ، فلا بد من صعودها

تفضل استاذ @أحمد الشحات85 الشرح والمرفق حسب ما فهمت . ووافني بالرد . Ahmed ElShahat.rar

تم معالجة المشكلة ولله الحمد .. 👍🙂 تم نقل الصفحة لموقع آخر يعمل بشكل مجاني .. وهذا هو الرابط الجديد وقد تم تحديثه أيضا في المشاركة الأساسية : https://script.google.com/macros/s/AKfycbwNEw1mNkjqgRndgyLnC89MLYI2C6UiEE-jlRNET0v__nAK377nD8WFkGHnmaTIvxgx/exec

اعرض الملف لعشاق كرة القدم (ملف أكسل لإحتساب نتائج كأس العالم 2026) رغم أني لا أنشط إلا في منتدى أكسس إلا أني اليوم قررت أن أرفق لكم ملف أكسل جميل كان قد أرسله لي شقيقي الأصغر هشام بعد أن وجده في أحد المواقع الأجنبيه وقام بتعريبه ووضع بعض التحسينات عليه وقد إستأذنته في رفعه إلى المنتدى ووافق بكل سرور كل ما عليكم هو إدخال النتائج في الورقة Match Results وسيقوم أكسل ببقية العمل أرجو أن ينال العمل إستحسانكم وإذا كان هناك أي ملاحظات فلا تتردوا في ذكرها تحياتي صاحب الملف منتصر الانسي تمت الاضافه 04/11/26 الاقسام قسم الإكسيل

اعرض الملف تشفير بيانات في رمز شريطي أو رمز الاستجابة السريعة barcode or Qr-Code Encode input data in a barcode or Qr-Code صاحب الملف عسل قليل الدسم تمت الاضافه 04/04/26 الاقسام قسم الأكسيس  

تفضل الملف حساب الفئة العمرية2.xlsx

وعليكم السلام ورحمة الله وبركاته بالنسبة للاوقات التي خارج الاوقات في M&N لم تحدده وفي اي بصمة تسجل تم ربط المعادلات حسب الاوقات في M&N اكسل1.xlsm

ممتاز ما قمت به . اكمل ما تريده ل 30 جدول و نشوف النتيجة النهائية بإذن الله

في المثال الذي ارفقته ، يمكنك الحصول على اي بيانات من الاعدادات الاقليمية ، فهناك بعض الامثلة على ذلك. هذا الكود كاملا من المرفق: Option Compare Database Option Explicit ' This code was originally written by Dev Ashish. ' It is not to be altered or distributed, ' except as part of an application. ' You are free to use it in any application, ' provided the copyright notice is left unchanged. ' ' Code Courtesy of ' Dev Ashish ' Public Const LOCALE_ILANGUAGE = &H1 ' language id Public Const LOCALE_SLANGUAGE = &H2 ' localized name of language Public Const LOCALE_SENGLANGUAGE = &H1001 ' English name of language Public Const LOCALE_SABBREVLANGNAME = &H3 ' abbreviated language name Public Const LOCALE_SNATIVELANGNAME = &H4 ' native name of language Public Const LOCALE_ICOUNTRY = &H5 ' country code Public Const LOCALE_SCOUNTRY = &H6 ' localized name of country Public Const LOCALE_SENGCOUNTRY = &H1002 ' English name of country Public Const LOCALE_SABBREVCTRYNAME = &H7 ' abbreviated country name Public Const LOCALE_SNATIVECTRYNAME = &H8 ' native name of country Public Const LOCALE_IDEFAULTLANGUAGE = &H9 ' default language id Public Const LOCALE_IDEFAULTCOUNTRY = &HA ' default country code Public Const LOCALE_IDEFAULTCODEPAGE = &HB ' default code page Public Const LOCALE_SLIST = &HC ' list item separator Public Const LOCALE_IMEASURE = &HD ' 0 = metric, 1 = US Public Const LOCALE_SDECIMAL = &HE ' decimal separator Public Const LOCALE_STHOUSAND = &HF ' thousand separator Public Const LOCALE_SGROUPING = &H10 ' digit grouping Public Const LOCALE_IDIGITS = &H11 ' number of fractional digits Public Const LOCALE_ILZERO = &H12 ' leading zeros for decimal Public Const LOCALE_SNATIVEDIGITS = &H13 ' native ascii 0-9 Public Const LOCALE_SCURRENCY = &H14 ' local monetary symbol Public Const LOCALE_SINTLSYMBOL = &H15 ' intl monetary symbol Public Const LOCALE_SMONDECIMALSEP = &H16 ' monetary decimal separator Public Const LOCALE_SMONTHOUSANDSEP = &H17 ' monetary thousand separator Public Const LOCALE_SMONGROUPING = &H18 ' monetary grouping Public Const LOCALE_ICURRDIGITS = &H19 ' # local monetary digits Public Const LOCALE_IINTLCURRDIGITS = &H1A ' # intl monetary digits Public Const LOCALE_ICURRENCY = &H1B ' positive currency mode Public Const LOCALE_INEGCURR = &H1C ' negative currency mode Public Const LOCALE_SDATE = &H1D ' date separator Public Const LOCALE_STIME = &H1E ' time separator Public Const LOCALE_SSHORTDATE = &H1F ' short date format string Public Const LOCALE_SLONGDATE = &H20 ' long date format string Public Const LOCALE_STIMEFORMAT = &H1003 ' time format string Public Const LOCALE_IDATE = &H21 ' short date format ordering Public Const LOCALE_ILDATE = &H22 ' long date format ordering Public Const LOCALE_ITIME = &H23 ' time format specifier Public Const LOCALE_ICENTURY = &H24 ' century format specifier Public Const LOCALE_ITLZERO = &H25 ' leading zeros in time field Public Const LOCALE_IDAYLZERO = &H26 ' leading zeros in day field Public Const LOCALE_IMONLZERO = &H27 ' leading zeros in month field Public Const LOCALE_S1159 = &H28 ' AM designator Public Const LOCALE_S2359 = &H29 ' PM designator Public Const LOCALE_SDAYNAME1 = &H2A ' long name for Monday Public Const LOCALE_SDAYNAME2 = &H2B ' long name for Tuesday Public Const LOCALE_SDAYNAME3 = &H2C ' long name for Wednesday Public Const LOCALE_SDAYNAME4 = &H2D ' long name for Thursday Public Const LOCALE_SDAYNAME5 = &H2E ' long name for Friday Public Const LOCALE_SDAYNAME6 = &H2F ' long name for Saturday Public Const LOCALE_SDAYNAME7 = &H30 ' long name for Sunday Public Const LOCALE_SABBREVDAYNAME1 = &H31 ' abbreviated name for Monday Public Const LOCALE_SABBREVDAYNAME2 = &H32 ' abbreviated name for Tuesday Public Const LOCALE_SABBREVDAYNAME3 = &H33 ' abbreviated name for Wednesday Public Const LOCALE_SABBREVDAYNAME4 = &H34 ' abbreviated name for Thursday Public Const LOCALE_SABBREVDAYNAME5 = &H35 ' abbreviated name for Friday Public Const LOCALE_SABBREVDAYNAME6 = &H36 ' abbreviated name for Saturday Public Const LOCALE_SABBREVDAYNAME7 = &H37 ' abbreviated name for Sunday Public Const LOCALE_SMONTHNAME1 = &H38 ' long name for January Public Const LOCALE_SMONTHNAME2 = &H39 ' long name for February Public Const LOCALE_SMONTHNAME3 = &H3A ' long name for March Public Const LOCALE_SMONTHNAME4 = &H3B ' long name for April Public Const LOCALE_SMONTHNAME5 = &H3C ' long name for May Public Const LOCALE_SMONTHNAME6 = &H3D ' long name for June Public Const LOCALE_SMONTHNAME7 = &H3E ' long name for July Public Const LOCALE_SMONTHNAME8 = &H3F ' long name for August Public Const LOCALE_SMONTHNAME9 = &H40 ' long name for September Public Const LOCALE_SMONTHNAME10 = &H41 ' long name for October Public Const LOCALE_SMONTHNAME11 = &H42 ' long name for November Public Const LOCALE_SMONTHNAME12 = &H43 ' long name for December Public Const LOCALE_SABBREVMONTHNAME1 = &H44 ' abbreviated name for January Public Const LOCALE_SABBREVMONTHNAME2 = &H45 ' abbreviated name for February Public Const LOCALE_SABBREVMONTHNAME3 = &H46 ' abbreviated name for March Public Const LOCALE_SABBREVMONTHNAME4 = &H47 ' abbreviated name for April Public Const LOCALE_SABBREVMONTHNAME5 = &H48 ' abbreviated name for May Public Const LOCALE_SABBREVMONTHNAME6 = &H49 ' abbreviated name for June Public Const LOCALE_SABBREVMONTHNAME7 = &H4A ' abbreviated name for July Public Const LOCALE_SABBREVMONTHNAME8 = &H4B ' abbreviated name for August Public Const LOCALE_SABBREVMONTHNAME9 = &H4C ' abbreviated name for September Public Const LOCALE_SABBREVMONTHNAME10 = &H4D ' abbreviated name for October Public Const LOCALE_SABBREVMONTHNAME11 = &H4E ' abbreviated name for November Public Const LOCALE_SABBREVMONTHNAME12 = &H4F ' abbreviated name for December Public Const LOCALE_SABBREVMONTHNAME13 = &H100F Public Const LOCALE_SYSTEM_DEFAULT& = &H800 Public Const LOCALE_USER_DEFAULT& = &H400 Const cMAXLEN = 255 Private Declare PtrSafe Function apiGetLocaleInfo Lib "kernel32" _ Alias "GetLocaleInfoA" (ByVal Locale As Long, _ ByVal LCType As Long, ByVal lpLCData As String, _ ByVal cchData As Long) As Long '''' Function CountryName() As String Dim lngLocale As Long Dim strLCData As String, lngData As Long Dim lngx As Long strLCData = String$(cMAXLEN, 0) lngData = cMAXLEN - 1 lngx = apiGetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SCOUNTRY, strLCData, lngData) If lngx <> 0 Then CountryName = Left$(strLCData, lngx - 1) End If End Function '''' Function fLocaleInfo(lngLCType As Long) As String Dim lngLocale As Long Dim strLCData As String, lngData As Long Dim lngx As Long strLCData = String$(cMAXLEN, 0) lngData = cMAXLEN - 1 lngx = apiGetLocaleInfo(LOCALE_USER_DEFAULT, lngLCType, _ strLCData, lngData) If lngx <> 0 Then fLocaleInfo = Left$(strLCData, lngx - 1) End If End Function Function fLOCALE_IMEASURE() As String ' 0 = metric, 1 = US Dim lngLocale As Long Dim strLCData As String, lngData As Long Dim lngx As Long strLCData = String$(cMAXLEN, 0) lngData = cMAXLEN - 1 lngx = apiGetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, _ strLCData, lngData) If lngx <> 0 Then fLOCALE_IMEASURE = Left$(strLCData, lngx - 1) End If End Function Function fList_Seperator() As String ' list seperator , OR ; Dim lngLocale As Long Dim strLCData As String, lngData As Long Dim lngx As Long strLCData = String$(cMAXLEN, 0) lngData = cMAXLEN - 1 lngx = apiGetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SLIST, _ strLCData, lngData) If lngx <> 0 Then fList_Seperator = Left$(strLCData, lngx - 1) End If End Function وهذا مثال لا يوجد في المرفق: اذا اردنا عمل برنامج يعمل لجميع عملات العالم ، فيجب علينا وضع الفاصلة بالطريقة الصحيحة لكل دولة حسب الاعدادات الاقليمية لتلك الدولة: 1. فاصلة الآلاف (من الكود ، يتضح ان تعريفه هو: Public Const LOCALE_SMONTHOUSANDSEP = &H17 ' monetary thousand separator ) 2. الفاصلة العُشرية (من الكود ، يتضح ان تعريفه هو:Public Const LOCALE_SMONDECIMALSEP = &H16 ' monetary decimal separator ) : 1. طريقة اضافة فاصلة الآلاف (LOCALE_SMONTHOUSANDSEP ) : نأخذ نسخة من كود الفاصلة مثلا ، A - اسم الدالة ، B - قيمة فاصلة الآلاف اعلاه . فيصبح الكود: Function fmonetary_thousand_Seperator() As String ' monetary thousand separator Dim lngLocale As Long Dim strLCData As String, lngData As Long Dim lngx As Long strLCData = String$(cMAXLEN, 0) lngData = cMAXLEN - 1 lngx = apiGetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SMONTHOUSANDSEP, _ strLCData, lngData) If lngx <> 0 Then fmonetary_thousand_Seperator = Left$(strLCData, lngx - 1) End If End Function Function fmonetary_decimal_Seperator() As String ' monetary decimal separator Dim lngLocale As Long Dim strLCData As String, lngData As Long Dim lngx As Long strLCData = String$(cMAXLEN, 0) lngData = cMAXLEN - 1 lngx = apiGetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SMONDECIMALSEP, _ strLCData, lngData) If lngx <> 0 Then fmonetary_decimal_Seperator = Left$(strLCData, lngx - 1) End If End Function . وعندما نريد التأكد منها ، نتأكد هكذا: ?fmonetary_decimal_Seperator . ?fmonetary_thousand_Seperator , . ولكن الحمدلله ، لا نحتاج لعمل هذا في الاكسس ، فالامر التالي يقوم بالمهمة: ?format(12345.67,"Standard") 12,345.67

وعليكم السلام ورحمة الله وبركاته جرب التعديل بالملف اكسل.xlsm

جمعت الحلين في مثال واحد واضطررت لحذف كل الأكواد المتعلقة بحل الأستاذ عسل قليل الدسم مع الاعتذار لمزيد من التركيز للسائلة. تجربة صادر_05.accdb

يمكن حلها كذلك بالأكواد إذا أردتها تظهر بتنسيق كما الوقت مع أن تنسيق الوقت لا يقبل أكثر من 24 ساعة. تقرير التأخير الشهري_03.xlsx

اعرض الملف توليد أرقام تلقائية مخصصة (ترقيم تلقائي احترافي) : Auto Increment توليد أرقام مستندات تلقائية مثل أرقام الفواتير والطلبات والسندات (ترقيم تلقائي احترافي) أربع أنماط للترقيم Yearly → INV-2026-000001 : التصفير واعادة الترقيم عند بدء العام الجديد Monthly → INV-2026-04-000001 : التصفير واعادة الترقيم عند بدء الشهر الجديد Daily → INV-2026-04-05-000001 : التصفير واعادة الترقيم عند بدء اليوم الجديد Sequential→ INV-000001 : ترقيم لا نهائى بدون اعادة بدء الترقيم مستمر بلا توقف المزايا : إنشاء تلقائي لجدول التسلسل : tblSequences وظيفته تخزين تسلسل الأرقام الفريد لكل مفتاح (Key) استرداد ذكي عند حذف جدول التسلسل : tblSequences عن طريق الخطأ تم تصميم الكود بحكمة ليعيد إنشاءه تلقائيا ويستأنف الترقيم من آخر رقم موجود في جدول البيانات الأصلي - أى لا انقطاع ولا تكرار أبدا التحكم الأمثل لإضافة بادئة مخصصة أى أنه يمكن عمل أكثر من عملية ترقيم لنفس الحقل حسب النوع, الفرع , المحافظة مثلا .... Cairo-2026-000018 Alex-2026-000001 التحكم فى شكل تنسيق الترقيم للأرقام بطول سلسلة مخصصة من 1 الى 10 مثل : 000001 أو 0000000001 أو حتى آمن في بيئة الشبكة المتعددة المستخدمين: عدم تكرار أي رقم حتى لو فتح عشرة مستخدمين نفس النموذج في نفس اللحظة مع عمل معالجة خاصة لمنع تعارض الطلبات المتزامنة مع حد أقصى للمحاولات لمنع التوقف التام تحت الضغط الشديد صاحب الملف عسل قليل الدسم تمت الاضافه 04/05/26 الاقسام قسم الأكسيس  

السلام عليكم ضع المعادلة =SUM(C8:C12) بدل الموجودة في خلية الجمع = SUM(C8+C9+C10+C11+C12) وفي الخلية c6 اكتب المعادلة =EOMONTH(P1;0) خطأ في الجمع و نهاية الشهر.xlsx

هههههههه انا قلت يمكن بعدل شي أو يضيف شي داخل الملف للتمييز بينهم 😛 إن شاء الله حال وصولي لنسبة ترضي غرور أفكاري 😁 ، لن أبخل عليكم بها

تم تحديث الأداة مع إضافة هذا الخيار

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

السلام عليكم هذة فكرة طرات في بالي منذ فترة ولكن لم اعمل على تطوريها او تجربتها المشكلة ان هناك اقسام للمستخدمين ولكن بعض المستخدمين لهم صلاحيات مخصصة والبعض لا ومن هنا جائت الفكرة الفكرة تعتمد على وجود جدول يحتوي على الازرار في صورة Btn ID (يتم حفظه داخل Btn Tag) و ID المستخدم مع امكانيات الاظهار و التمكين وعند فتح النموذج يقوم النموذج بمراجعة صلاحيات كل زر الهدف من استخدام Btn ID داخل الـ Tag هو اختصار الكثير من الازار داخل مجموعة من الـ Btns IDs (مجموعة من الازار لهم جميعا نفس الـ Btn ID) هي مجرد فكرة ولكن اتمنى راي حضراتكم

اتفضل CARD3.zip

ما شاء الله اخوي خليفة ,, تفصيل اكثر من الطلب والحاجة سلمت اناملك

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

اعرض الملف 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 الاقسام قسم الأكسيس  

انا كتبت رأيي هنا .

بعد إذن الاستاذ/ عبد الله إليك اصلاح كود الدوائر مثال للتوضح والمطلوب - 222 (2).xlsm

وعليكم السلام وحمه الله اتفضل لعله المطلوب برمجة اكسل (1).xlsm تم تصميم الصوره ب ai برمجة اكسل (1).xlsm

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

أخواني وأساتذتي ومعلمينا ( دون استثناء ) يتوفر نظام متكامل للتفعيل من خلال الإنترنت بالمميزات التالية :- نظام بصمة لكل جهاز فريد وغير متكرر . التفعيل من خلال البريد الإلكتروني + بصمة الجهاز . سيرفر يسجل جميع النسخ التي تم تشغيلها لبرنامجك . رمز Pin لتأكيد التفعيل بالبريد الإلكتروني بمدة محددة = 5 دقائق ، عند التفعيل لأول مرة فقط . إمكانية استرجاع التفعيل لنسخة العميل حتى بعد الفرومات وتغيير الجهاز . دعم متكامل للشركات التي تستخدم برنامجك على أكثر من جهاز . فيمكن استعمال رمز التفعيل على عدد تقرره وتحدده انت يصل لـ 100 جهاز على سبيل المثال ليقوم بالتفعيل من خلال رمز تفعيل واحد . دعم التفعيل المرن بمدة حسب الحاجة ( شهر ، 3 شهور ، 6 شهور ، سنة ، مدى الحياة ، مدة محددة على سبيل المثال 40 يوماً ) . دعم إمكانية حجب نسخة عميل من التفعيل واستخدام البرنامج . دعم الإقفال عند التلاعب بالوقت والتاريخ مضبوط بشكل محكم 101% . واجهة للمطور مخصصة بالتفعيل عن بعد . أو بإرسال رقم التفعيل للعميل لاستخدامه بشكل يدوي . سيرفر مدعوم من جوجل مجاني يصل لـ 15 جيجا كحجم بيانات . دعم الصيانة على الأداة المخصصة بالتفعيل 6 شهور بعد البيع . نسخة تجريبية يمكن التحكم بها - الإفتراضية 7 أيام . للتواصل من خلال الواتس أب :- 00962787818180

يمكن وضعه كنموذج فرعى داخل اى نموذج وسوف يعمل على الفور بدون ادنى تدخل الاكواد التى تمت كتابتها لهذا العمل Option Compare Database Option Explicit Private mHostForm As Access.Form Private mRecordCount As Long Private mIsInitialized As Boolean Private mLastPosition As Long Private mLastCount As Long Private mLastIsNew As Boolean Private mHasLastState As Boolean Private Sub Form_Load() InitializeNavigator End Sub Private Sub InitializeNavigator() If Not EnsureHostForm Then Exit Sub RefreshRecordCount True With mHostForm.Recordset If Not (.BOF And .EOF) Then .MoveFirst End With UpdateUI mIsInitialized = True End Sub Private Sub Form_Current() If mIsInitialized Then UpdateUI End Sub Private Function EnsureHostForm() As Boolean On Error GoTo ErrorHandler If mHostForm Is Nothing Then If TypeOf Me.Parent Is Form Then Set mHostForm = Me.Parent End If ExitFunction: EnsureHostForm = Not (mHostForm Is Nothing) Exit Function ErrorHandler: Set mHostForm = Nothing Resume ExitFunction End Function Private Function HasRecords() As Boolean HasRecords = (mRecordCount > 0) End Function Private Sub RefreshRecordCount(Optional ByVal force As Boolean = False) On Error GoTo ErrorHandler If Not EnsureHostForm Then mRecordCount = 0 Exit Sub End If If Not force Then If mRecordCount > 0 Then Exit Sub End If With mHostForm.RecordsetClone If .BOF And .EOF Then mRecordCount = 0 Else .MoveLast mRecordCount = .recordCount End If End With ErrorHandler: End Sub Private Function GetCurrentPosition() As Long On Error GoTo ErrorHandler If Not EnsureHostForm Then GetCurrentPosition = 0 ElseIf mRecordCount <= 0 Then GetCurrentPosition = 0 ElseIf mHostForm.NewRecord Then GetCurrentPosition = mRecordCount + 1 Else Dim pos As Long pos = mHostForm.CurrentRecord If pos <= 0 Then pos = 1 GetCurrentPosition = pos End If Exit Function ErrorHandler: GetCurrentPosition = 0 End Function Private Sub UpdateUI() On Error GoTo SafeExit Dim frm As Form Dim currentPosition As Long Dim isEmpty As Boolean Dim isNew As Boolean Dim isFirst As Boolean Dim isLast As Boolean If Not EnsureHostForm Then If Not mHasLastState _ Or mLastPosition <> 0 _ Or mLastCount <> 0 _ Or mLastIsNew <> False Then Me.lblRecordPosition.Caption = "0 of 0" Me.cmdGoFirst.Enabled = False Me.cmdGoPrevious.Enabled = False Me.cmdGoNext.Enabled = False Me.cmdGoLast.Enabled = False Me.cmdDeleteCurrent.Enabled = False mLastPosition = 0 mLastCount = 0 mLastIsNew = False mHasLastState = True End If Exit Sub End If Set frm = mHostForm currentPosition = GetCurrentPosition() isEmpty = (mRecordCount <= 0) isNew = frm.NewRecord If mHasLastState Then If mLastPosition = currentPosition _ And mLastCount = mRecordCount _ And mLastIsNew = isNew Then Exit Sub End If If isEmpty Then Me.lblRecordPosition.Caption = "0 of 0" Else Me.lblRecordPosition.Caption = currentPosition & " of " & mRecordCount End If isFirst = (currentPosition <= 1 And Not isNew) isLast = (currentPosition >= mRecordCount And Not isNew) Me.cmdGoFirst.Enabled = Not isEmpty And Not isFirst Me.cmdGoPrevious.Enabled = Not isEmpty And Not isFirst Me.cmdGoNext.Enabled = Not isEmpty And Not isLast And Not isNew Me.cmdGoLast.Enabled = Not isEmpty And Not isLast And Not isNew Me.cmdDeleteCurrent.Enabled = Not isEmpty And Not isNew mLastPosition = currentPosition mLastCount = mRecordCount mLastIsNew = isNew mHasLastState = True Exit Sub SafeExit: Debug.Print "UpdateUI Error: "; Err.Number; " - "; Err.Description End Sub Private Sub cmdGoFirst_Click() If Not EnsureHostForm Then Exit Sub If Not HasRecords Then Exit Sub On Error GoTo ErrorHandler With mHostForm.RecordsetClone .MoveFirst mHostForm.Bookmark = .Bookmark End With UpdateUI Exit Sub ErrorHandler: HandleNavigatorError Err.Number, Err.Description End Sub Private Sub cmdGoPrevious_Click() If Not EnsureHostForm Then Exit Sub If Not HasRecords Then Exit Sub If mHostForm.NewRecord Then cmdGoLast_Click Exit Sub End If On Error GoTo ErrorHandler With mHostForm.RecordsetClone .Bookmark = mHostForm.Bookmark If mHostForm.CurrentRecord > 1 Then .MovePrevious mHostForm.Bookmark = .Bookmark End If End With UpdateUI Exit Sub ErrorHandler: HandleNavigatorError Err.Number, Err.Description End Sub Private Sub cmdGoNext_Click() If Not EnsureHostForm Then Exit Sub If Not HasRecords Then Exit Sub If mHostForm.NewRecord Then Exit Sub On Error GoTo ErrorHandler If mHostForm.CurrentRecord >= mRecordCount Then UpdateUI Exit Sub End If With mHostForm.RecordsetClone .Bookmark = mHostForm.Bookmark .MoveNext If Not .EOF Then mHostForm.Bookmark = .Bookmark End With UpdateUI Exit Sub ErrorHandler: HandleNavigatorError Err.Number, Err.Description End Sub Private Sub cmdGoLast_Click() If Not EnsureHostForm Then Exit Sub If Not HasRecords Then Exit Sub On Error GoTo ErrorHandler With mHostForm.RecordsetClone .MoveLast mHostForm.Bookmark = .Bookmark End With UpdateUI Exit Sub ErrorHandler: HandleNavigatorError Err.Number, Err.Description End Sub Private Sub cmdCreateNew_Click() On Error GoTo ErrorHandler If Not EnsureHostForm Then Exit Sub mHostForm.SetFocus DoCmd.GoToRecord acDataForm, mHostForm.name, acNewRec RefreshRecordCount True UpdateUI Exit Sub ErrorHandler: HandleNavigatorError Err.Number, Err.Description End Sub Private Sub cmdDeleteCurrent_Click() If Not EnsureHostForm Then Exit Sub If Not HasRecords Then Exit Sub If mHostForm.NewRecord Then Exit Sub If MsgBox("هل تريد حذف السجل الحالي نهائيًا؟", vbYesNo + vbQuestion + vbDefaultButton2, "تأكيد الحذف") <> vbYes Then Exit Sub On Error GoTo ErrorHandler Dim rsClone As DAO.Recordset Dim bm As Variant Dim nextBM As Variant Set rsClone = mHostForm.RecordsetClone bm = mHostForm.Bookmark rsClone.Bookmark = bm rsClone.MoveNext If rsClone.EOF Then rsClone.Bookmark = bm rsClone.MovePrevious If rsClone.BOF Then nextBM = Null Else nextBM = rsClone.Bookmark End If Else nextBM = rsClone.Bookmark End If If mHostForm.Dirty Then mHostForm.Dirty = False End If mHostForm.Recordset.Delete RefreshRecordCount True If IsNull(nextBM) Then mHostForm.SetFocus DoCmd.GoToRecord , , acNewRec Else mHostForm.Bookmark = nextBM End If rsClone.Close Set rsClone = Nothing UpdateUI Exit Sub ErrorHandler: On Error Resume Next If Not rsClone Is Nothing Then rsClone.Close Set rsClone = Nothing End If HandleNavigatorError Err.Number, Err.Description End Sub Private Sub HandleNavigatorError(ByVal errorNumber As Long, ByVal errorDescription As String) Select Case errorNumber Case 0, 3021 Exit Sub Case Else MsgBox "حدث خطأ رقم " & errorNumber & vbCrLf & errorDescription, vbExclamation, "خطأ في أداة التنقل" End Select End Sub Navigator.accdb

وعليكم السلام ورحمة الله وبركاته 🙂 تفضل أخي بلالشريط متحرك.mdb

حسب ما فهمت جرب الملف التالي اغلاق الصفوف ذات الرصيد 0 (2).xlsm

حل آخر بالأكواد، في الموضوع السابق فهمتك خطأ بأنك تريد أن يبدأ الشهر دائما مع يوم الأحد وقد تم التعديل في هذه النسخة يتم مراجعة خلية العام الدراسي في حال لم يتم تعديله من قبلكم. حساب_التاريخ_09.xlsm

تم تنقيح الكود لتسهيل التعديل عليه Private Sub Worksheet_Change(ByVal Target As Range) Dim Row As Integer, Col As Integer Dim fRow As Integer, fCol As Integer, fdd As Integer Dim yy As Integer, mm As Integer, dd As Integer Dim cellDate As Date, DateRange As String, m m = Array("", "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") With Target DateRange = Replace(.Address, "$", "") If DateRange <> "M1" Then 'تبديل عنوان خلية التاريخ عند الحاجة' Beep 'MsgBox Exit Sub End If If Not IsDate(Range(DateRange)) Then Beep 'MsgBox Exit Sub End If Application.EnableEvents = False Application.ScreenUpdating = False yy = Year(.Value) mm = Month(.Value) For fdd = 1 To 7 If Weekday(DateSerial(yy, mm, fdd)) = vbSunday Then Exit For Next fdd End With Cells.Find(What:="الأحد", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate fRow = ActiveCell.Row fCol = ActiveCell.Column + 1 Cells(fRow - 2, fCol + 5) = m(mm) dd = fdd - 3 For Col = fCol To fCol + 9 Step 2 dd = dd + 2 For Row = fRow To fRow + 4 dd = dd + 1 cellDate = DateSerial(yy, mm, dd) If Month(cellDate) = mm Then Cells(Row, Col + 0) = cellDate Cells(Row, Col + 1) = 1 Else Cells(Row, Col + 0) = "" Cells(Row, Col + 1) = "" End If Next Row Next Col Application.EnableEvents = True Application.ScreenUpdating = True End Sub حساب_التاريخ_06.xlsm

اعرض الملف أداة عرض وتحرير جمل Sql داخل التطبيق {سلسلة الأدوات المساعدة المخصصة} اقدم لكم اليوم أداة ستزيد من إنتاجيتكم أثناء العمل مع الإستعلامات فبدلاً من العمل مع الإستعلامات من خلال جزء التنقل ستقوم هذه الأداة بتجميع جميع الإستعلامات داخل مربع قائمة والجميل أنه لن يتم تحميل القائمة إلا بالإستعلامات التي تم تحديد نوعها فمثلاً تريد العمل مع إستعلامات التحديث فقط أو الإلحاق فقط وهكذا بالإضافة إلى هذا يمكنك تصفية النتائج من خلال كتابة عبارة نصية تتضمنها جملة Sql فمثلاً تريد الإستعلامات التي تتضمن بيانات جدول محدد فيكفي أن تكتب إسم الجدول في مربع التصفية ليتم تصفية الإستعلامات التي تتضمن هذا الجدول فقط وكمثال رائع آخر وأعتقد أن جميعنا سيعجب به إذا قمنا مثلا بتعديل إسم عنصر تحكم في نموذج وسبق أن تم وضع عنصر التحكم هذا كمعيار لتصفية إستعلام أو أكثر فيمكن كتابة إسمه في مربع التصفية ليتبقى لدينا الإستعلامات التي ذكر فيها إسم عنصر التحكم هذا لا وأزيدكم من الشعر بيت يمكنكم بعد ذلك إستبدال إسم عنصر التحكم هذا بالإسم الجديد وإستعراض النتائج في إستعلام مؤقت وإذا نجح العمل يمكنك تحديث جملة Sql الخاصة بالإستعلام المحدد بالتعديلات الجديدة وهذا كله عن طريق الأداة وبدون حتى أن تضطر إلى فتح الإستعلام في وضع التصميم يوجد للأداة وظيفة أخرى وهي تعديل جملة Sql الخاصة بعناصر التحكم (مربعات التحرير والسرد ومربعات القائمة) وتقوم بنفس ماسبق ذكره ولكن على عبارة Sql لمصدر الصف الخاص بعنصر التحكم الأداة بسيطة ولا تحتوي إلا على ثلاثة نماذج فقط ستجدونها في المرفق بإسم القالب يمكنكم إستيرادها إلى تطبيقاتكم والعمل بها بكل سهولة ولكن الخيار المفضل لدي هو إستخدامها كوظيفة إضافية وهي ما ستجدونه داخل مجلد الوظيفة الإضافية مع مستند يشرح طريقة تثبيتها أرجو أن تجدوا في هذه الأداة الفائدة التي وجدتها أنا شخصيا وإذا كان لدى أي أحد منكم أي ملاحظات فالرجاء أن لا يبخل علينا بها تحياتي صاحب الملف منتصر الانسي تمت الاضافه 04/01/26 الاقسام قسم الأكسيس  

نعم الموقع ثقة ، وانا اشرت الى هذا في الرابط التالي ، وهناك رد من الاخ @محمد سلامة عن طريقة لا اعرفها:

اليك الملف البحث في القائمة بالحروف.xlsm