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

بسم الله الرحمن الرحيم السلام عليكم ورحمه الله وبركاته اساتذتي واخوتى هذا الملف به فهرس لجميع المنتدي ليسهل البحث للاعضاء يوجد فورم يمكنك البحث بها كما يمكنكم استخدام الفلتر العادي وبمجرد الضغط على اي نتيجه من نتائج البحث يتم فتح صفحتها في المنتدي ولا انسي فضل استاذي الكبير ياسر خليل على المساعده في عمل الملف تم تحديث الملف يوم الخميس الموافق 10 - 04 - 2025 فهرس منتدي الاكسيل.xlsb

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

السلام عليكم ورحمة الله تعالى وبركاته نظرا للطلب والتساؤلات الكثيرة حول الموضوع او نقاط فرعيه منه قاصدا من ذلك أن يكون الموضوع شاملا ومرجعا للراغبين فى ذلك والدراسبن اليكم بناء القاعدة والذى اتمنى على الله تعالى ان يبدأ البناء وينتهى بشكل احترافى بقدر الإمكان وسوف نبدأ من الصفر تباعا ان شاء الله سوف يتم تحديث الموضوع تباعا الموضوع بأمر الله سوف اضع له الخطوط العريضة طبقا للمؤسسة التى اعمل بها لاننى أصلا سوف اقوم بقاعدة البيانات لمؤسستى وبقدر الإمكان سوف أضع فى الحسبان ان يكون التصميم عام بقدر الإمكان ليتناسب ويتماشى مع الجميع ومع رغباتهم بقدر الإمكان اهلا بكل من يريد المشاركة فى ادراة الموضوع والافكار والتعديل او الاضافة و ...... مبدئيا خلونا نتفق وقتى ضيق فى الفترة المقبلة لما انا مقدم عليه فلذلك ارجو الاعتذار مقدما ان لم التفت الى اى تساؤلات والتى وإن حدث سوف يتم تأجيلها حتى ينتهى مشروع اعداد التطبيق لمؤسستى تماما ان شاء الله بسم الله وعلى بركة الله بداية المشروع اول شئ تصيد وتسجيل الاخطاء بجدول وده وظيفته تسجيل الحطأ باسم الحدث أو الدالة المستخدمة فى الكود عند تنفيذ امر ما ورقم الخطا وصفه للمساعدة مستقبلا فى الوقوف على اماكن الاخطاء لعمل الصيانة اللازمة طبعا تم التطرق اليه فى هذا الموضوع: ويمكنكم الذهاب اليه والمتابعة من هنا طيب حلو جدا جدا وعلشان انا هبدأ بالأكواد ملاحظات هامة جدا جدا جدا جدا لبداية صحيحة واحترافيه : كتابة كود احترافي تتطلب ممارسات جيدة واتباع مبادئ برمجية صحيحة. فيما يلي بعض النصائح التي يمكن أن تساعدك في كتابة كود احترافي: توضيح الكود: استخدم تعليقات لشرح الجزء العلوي من الكود وللأمور المعقدة. اختر أسماء مفيدة وواضحة للمتغيرات والدوال تدل على وظائفها التى تمت كتابتها من اجلها. التنظيم: استخدم الهندسة المعمارية لتنظيم البرنامج إلى وحدات صغيرة وقابلة لإعادة الاستخدام. قم بتقسيم البرنامج إلى وحدات ووظائف مستقلة. الأداء: ابتعد عن الأكواد المكررة وقدّم الأكواد القابلة لإعادة الاستخدام في وحدات. حافظ على الأداء بتجنب العمليات الزائدة غير الضرورية. اختبار الوحدات: قم بكتابة اختبارات للتأكد من أن وحدات الكود الخاصة بك تعمل كما هو متوقع. الأمان: تحقق دائمًا من صحة البيانات الواردة والخارجة من الدوال. تفادى استخدام الأكواد المعرضة لثغرات أمان. تحسين الأداء: استخدم الهندسة العكسية لتحسين الأداء. ابحث عن فرص لتحسين الكفاءة والسرعة. استخدام التعليمات البرمجية النظيفة: ابتعد عن استخدام المتغيرات العالمية عندما لا تكون ضرورية. تجنب الأكواد التي تعتمد على التبديلات الطويلة. توثيق الكود: وفر توثيقًا جيدًا للكود ليسهل على المطورين الآخرين أو نفسك فهم كيف يعمل البرنامج. متابعة المعايير: اتبع معايير البرمجة المتعارف عليها . التحسين المستمر: كن مستعدًا لتحسين الكود الخاص بك بناءً على التعلم وتغييرات متطلبات المشروع. الالتزام بتلك المبادئ يمكن أن يساعدك في كتابة كود أكثر احترافية وقابل للصيانة. حلو الكلام وكل ده هيبان بقدر المستطاع فى التعليمات البرمجية التى سوف تتم تباعا يمكنك استخدام البادئات التالية لتسمية العناصر والكائنات بشكل منظم ويجعل الشيفرة أكثر وضوحًا. البادئات تعتمد على النوع أو الدور الذي تقوم به العناصر: وعلى سبيل المثال وليس الحصر المتغيرات: int للأعداد الصحيحة. dbl للأعداد العشرية. str للنصوص. bool للقيم البولية اى True , False أو Yes , No . Dim intCounter As Integer Dim dblAmount As Double Dim strName As String Dim boolIsValid As Boolean المصفوفات: arr للمصفوفات. Dim arrNames() As String الدوال: Function للدوال التي تعيد قيمة. Sub للإجراءات (دوال بدون إرجاع قيمة). Function CalculateTotal() As Double Sub DisplayMessage() الكائنات: frm للنماذج (Forms). rpt للتقارير (Reports). tbl للجداول (Tables). qry للاستعلامات (Queries). cls للكائنات أو الفئات لتعريف الكلاسات (Classes). bas وحدات الشيفرة- الوحدات النمطية (Modules). tbl للجداول (Tables). qry للاستعلامات (Queries). Dim frmCustomer As Form Dim rptSales As Report Dim tblData As TableDef Dim qryFilteredData As QueryDef الثوابت: c للثوابت. Const cMaxValue As Integer = 100 المتغيرات العامة: g للمتغيرات العامة. Public gCounter As Integer المتغيرات المؤقتة: temp للمتغيرات المؤقتة. Dim tempValue As Integer التعليقات: REM لتعليقات الشيفرة. REM هذا تعليق لشرح الشيفرة الأشكال والعناصر الرسومية: btn للأزرار (Buttons). lbl للتسميات (Labels). txt لحقول النص (Textboxes). chk لمربعات الاختيار (Checkboxes). القوائم والمراقبين: cmb لقائمة الاختيار (Comboboxes). lst لقوائم الاختيار (Listboxes). cb لمراقبات الصندوق (Checkboxes). الكائنات الأخرى: app لكائن التطبيق (Application). cnn لكائن الاتصال (Connection). doc لكائن المستند (Document). الحقول والأعمدة: fld لحقول البيانات (Fields). col لعمود البيانات (Column).

احببت ان افرد موضوعي هذا بعنوان مستقل 1-لان غالب او جميع الدروس هنا تتعامل مع واتساب ويندوز 2-وحتى يكون تطوير هذا العمل مستقلا ولا يحدث خلط بين الامثلة المثال المرفق تم تطبيقه على واتساب ويب واليكم بعض التوجيهات والملاحظات : كانت مشكلتي في محاولات سابقة انه في كل مرة يتم الارسال وفتح الواتساب ويب .. فانه يطلب ربطا جديدا بالجوال وبحمد الله توصلت الى حل هذه المشكلة التي كانت عائقا حقيقيا .. يكتفى بالارتباط مرة واحدة فقط الآن : عند كل ارسال يفتح الواتس ويب بشاشة جديدة .. فان كانت هناك نسخة مفتوحة من قبل فانه يتجاهلها وتصبح غير فعالة وهذه لا مشكلة فيها لأنه يفتح على الحساب نفسه . ارجوا من اخوتي واحبتي الذين يمرون من هنا تجربة المثال وافادتي بنتيجة التجربة ، من اجل الانتقال الى الخطوة التالية وهي ارسال المرفقات ملحوظة : المرفق sendwatsWebAll .. هو النسخة المحدثة والمطورة بعد أخذ آراء وتجارب الإخوة sendwatsWeb.mdb sendwatsWebAll.rar

اعرض الملف 🎁📅 :: المخطط السنوي للإجازات :: 🌼🌷 :: عرض جميع إجازات الموظفين على الجدول الزمني Gantt Cart دايناميكي 😊👌🏻 السلام عليكم ورحمة الله وبركاته 🙂 اليوم يسرني أن أقدم لكم هذه الهدية المتواضعة :: المخطط السنوي للإجازات :: وهو عبارة عن تقويم سنوي لإجازات الموظفين يتم رسمه دايناميكيا على مخطط رسم بياني يسمى Gantt Chart 👌 يمتاز التصميم بالسهولة والجمال والإبداعية وقد شرحت كيفية استخدامه في الفيديو التالي ✌ في التحديث الجديد 1.7 تم إضافة حقل لمجموع عدد الأيام سنويا ... مع دعم للإجازات عابرات القارات (الإجازات التي تمتد لعدة سنوات كالإجازات الدراسية الطويلة) ظهور عدد الأيام في جميع النوافذ من مميزات هذا المخطط: - عرض جميع الإجازات في صفحة واحدة يسهل من قرائتها ومراجعتها. - تصميم رائع وألوان جميلة . - سهل الاستخدام . - وكذلك هذا المخطط يمكن استخدامه للمشاريع بدل الإجازات أو عرض مدة الإيجارات أو .. أو .. أو ... حيث لا حدود للإبداع 🙂 :: وأخيرا وليس آخرا :: :: لا تنسونا ووالدينا من صالح دعواتكم الطيبة 🙂 🌹🌷 :: صاحب الملف Moosak تمت الاضافه 01 ينا, 2025 الاقسام قسم الأكسيس

هذه طريقتي في إعادة تسمية العناصر الكثيرة دفعة واحدة في النموذج بأسماء متسلسلة مثل : ( Box2 , Box1 , ... ) هو كود وقد عملت له نموذج لتسهيل العمل .. 🙂 الكود يقوم أيضا بترتيب وتنسيق العناصر في شكل منتظم لتسهيل عملية التصميم 😊 إقرأ الملاحظات جيدا قبل أن تطبق 😉👌🏻 النموذج : النتيجة ستكون هكذ : ( من >>>> إلى ) >>>> >>>> للاستفادة من هذا النموذج .. قم بنقل النموذج لقاعدة البيانات عندك وسيتعرف تلقائيا على النماذج التي عندك 🙂 ملف التحميل : إعادة تسمية العناصر مع الترتيب بواجهة مرنة.accdb

السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم بكل خير وسرور .. وتقبل الله منا ومنكم صالحات الأعمال .. 😊🤲🏻 يطيب لي أن أقدم لكم هذا الهدية المتواضعة بمناسبة هذا الشهر الفضيل 🙂🌼🎁 استبدل الرسائل العادية في أكسس برسائل ذات تصاميم قمة في الإبداع وبمميزات إضافية . من مميزات هذه الرسائل: - تصميم جميل وألوان جذابة. - خاصية ذاتية الاختفاء. - عنوان رئيسي + عنوان فرعي - تحكم بالنص ( عربي - إنجليزي ) ( توسيط - محاذاة على اليمين أو اليسار) - سهلة الاستخدام . الشرح على اليوتيوب : التحميل 🙂 Moosak MsgBox.accdb ولا تنسوني من صالح دعواتكم 😊🌷🌼🌹

السلام عليكم ورحمة الله وبركاته 🌹 درسنا اليوم عن طريقة عمل قوائم ديناميكية متحركة بأقل عدد من الأكواد وطريقة مبتكرة . 🙂 النتيجة النهائية : الشرح : تحميل الملف : Dynamic Menus.accdb

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

شرف ليا انى اضيف موضوع وسط اساتذتى https://www.mediafire.com/file/pzr38qxqwg4e2a2/Ferry_Login_v1-_free.accdb/file Ferry Login v1free.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) لكثرة الطلبات على برنامج إدارة الحضور والإنصراف للموظفين ، وددت مشاركتكم النسخة الأولى الغير مفتوحة المصدر حالياً ، لحين الإنتهاء من التعديلات التي ستتم على البرنامج . دون الإطالة في المقدمة ؛ سأشرح لكم بعض ميزات البرنامج :- أولاً سيتم إضافة الإعدادات الضرورية للبرنامج وهي :- تصنيف الموظفين ( ولكل تصنيف سيتم تحديد عدد أيام الإجازات السنوية له ) . تصنيف الإجازات ( طارئة ، مرضية ، ..... إلخ ) . تحديد وقت بداية ونهاية ساعات العمل الرسمي ، و تحديد مدة السماح للتأخير ( المرونة في العمل ) ، تحديد عدد مرات التأخير ليتم احتساب يوم إجازة في اليوم الأخير من المدة . ثانياً ومن الطبيعي وجود موظفين في قاعدة البيانات ، سيكون قسم لإدخال بيانات الموظفين بشكل بسيط من المعلومات ( ولكم حرية التوسع حسب رغبتكم وحاجتكم كمستخدمين ) ، وطبعاً لكل موظف رقم وظيفي خاص به اعتمد على سلسلة مكونة من التاريخ والوقت الحالي بدون مسافات بهذا التنسيق YYYYMMDDhhmmss ، بحيث لا يكون هناك تكرار نهائي لأي رقم موظف . ثالثاً لوحة تسجيل الحضور والإنصراف عن طريق الرقم الوظيفي ، وتدعم القراءة من الباركود الموجود على باجة الموظف ( طبعاً لاحقاً سيتم إضافة طباعة باجة أو بطاقة للموظف ) ، وفي هذه اللوحة لن تحتاج تحديد الحالة ( حضور أو إنصراف ) فقط أدخل رقم الموظف وسيتم احتساب وقت الحضور وتسجيل مدة التأخير بالدقيقة في الجدول ، وكذلك الأمر للإنصراف . رابعاً لوحة تسجيل الإجازات ، وطبعاً بناءً على المعطيات التي تم إدخالها في نماذج البيانات الأساسية في الإعدادات - سيكون الأمر بسيطاً جداً وتم اعتماد رقم الموظف في المرحلة الأولى من البرنامج وسيتم اعتماد اسم الموظف أيضاً لجلب البيانات لاحقاً . بخطوات بسيطة بعد ادخال رقم الموظف نحدد تاريخ بداية الإجازة ، ثم عدد الأيام المطلوبة كإجازة ، ثم سيتم تلقائياً احتساب يوم نهاية الإجازة ، وطبعاً نوع الإجازة المطلوبة ستقوم باختياره من قائمة نوع الإجازة . خامساً لوحة التقارير ، بحيث سيكون لدينا في المشروع تقرير واحد فقط لكنه سيخدم جميع الطرق التي تريدها كمستخدم ( تقرير للموظفين جميعاً مع وبدون تحديد فترة ، تقرير لموظف واحد مع وبدون تحديد فترة ) . *وطبعاً ما زالت قيد التطوير بشكل خاص ملاحظة:- تم حفظ البرنامج بصيغة Accde كونه قيد التطوير والتعديل حالياً اقترب عيد المسلمين مودعين به شهرهم الفضيل أعاده الله علينا وعليكم باليمن والبركات . وتقبل الله منا ومنكم الطاعات وصالح الأعمال . وسأختم به آخر تعديل على هذا المشروع البسيط ؛ متمنياً أن يكون على قدر الجهد المبذول فيه . وأعتذر بداية عن التأخير في انهاء العمل عليه ، ولكن لضيق الوقت ليس إلا . اليوم انهيت تأسيس الأساسيات في برنامج إدارة الحضور والإنصراف الذي يعمل بنظام بصمة الـ QR . وسأذكر بالتفصيل البسيط ما تم إضافته . الإضافات في النماذج :- ربط قارىء QR يعمل عن طريق الـ USB أو عن طريق الجوال بالنظام . دعم كامل لللغة العربية في قراءة رمز الإستجابة السريعة QR . اعتماد اسم الموظف بالإضافة الى رمز الـ QR . نظام التنبيه لضبط الإعدادات الرئيسية في البرنامج عند تشغيله أول مرة . إحصاء لعدد الموظفين ، الحضور ( على رأس عملهم ) ، المجازين ، المغادرات خلال اليوم . ترحيل بيانات الإجازات والمغادرات والحضور بشكل شهري ( بداية كل شهر ) . الإضافات في الأكواد :- تمت مراجعة جميع الأكواد من أي خطأ محتمل في التنظيم أو آلية العمل . تم إضافة فكرة تثبيت برنامج الربط Barcode2Win من خلال الأكواد ، وفي حال عدم وجوده يتم تحميله من الموقع الرسمي ( يتطلب انترنت ) . تم دمج العديد من الإستعلامات في الأكواد لتقليل مكونات وعناصر النظام وتخفيف العبئ عليه . تم تقسيم العديد من الوظائف لسهولة التعامل معها وصيانتها . تم إضافة نموذج لإعادة تهيئة النظام وتفريغ محتوياته ( الجداول ) ، طبعاً باسوورد تأكيد العملية مدمج في أكواد النموذج . العديد من المميزات التي ستجدونها في المشروع

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاتة اهلا بكم اعضاء المنتدى الكرام اعتذر جدا للغياب الطويل عن المنتدى ولكن اشتقت اليكم فقولت ارجع بكود ممكن يفيد البعض فى عملة يعتبر البحث عن البيانات من الامور التى يبحث عنها كل مستخدمى الاكسل حيث انها تسهل عليهم اعمالهم وتحليل البيانات لديهم ولكن اذا كان لديك بيانات كثيرة جدا فى شيت الاكسل فالامر هنا يكون شاق ومرهق ومن هنا قررنا انشاء كود بحث من خلال اليوزرفورم يقوم بالبحث عن البيانات وتلوين واظهار نتائج البحث يتم وضع الكود فى حدث التكست بوكس Dim Itemsaerch As String Dim rng As Range Dim cell As Range Dim lr As Long Sheet1.Cells.Interior.Pattern = xlNone Itemsaerch = Me.TextBox1.Value lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row Set rng = Sheet1.Range("a2:a" & lr) For Each cell In rng If InStr(1, cell.Value, Itemsaerch) > 0 Then cell.Interior.Color = vbGreen End If Next cell If Me.TextBox1.Value = "" Then Sheet1.Cells.Interior.Pattern = xlNone ملف العمل فورم بحث جديد وتلوين نتائج البحث.xlsm

السلام علبكم 🙂 بسبب اختلاف تنسيقات ملفات الاكسل (او CSV) ، وخصوصا تلك التي من مواقع وزارة التعليم في المملكة العربية السعودية ، كنا نضطر ان نتعامل بالكود مع كل تنسيق بطريقة تختلف عن الملف الآخر ، مما يجعل الحل لا يتناسب مع التنسيقات الملفات الاخرى ، وهذا الكود ليس بالسهل تعديله. ولكن ، تقريبا جميع مستخدمي الاكسس يعرفون التعامل مع الاستعلام ، لهذا السبب دعونا نتعامل مع بيانات الاكسل في استعلام ، استعلام مسقط 🙂 هذه واجهة النموذج الذي يتم كل شيء عن طريقه: 1. لتصفح الملفات ، واختيار ملف الاكسل (xls, xlsx, xlsm, csv) ، وسيظهر اسم الملف الذي تم اختيارة في الحقل رقم 2 ، 3. ستظهر قائمة بأسماء الاوراق (Sheets) الموجودة في الملف ، ويجب اختيار الورقة المطلوبة ، 4. هذا نموذج جدولي ، و ستظهر بيانات ورقة الاكسل هنا ، ويمكننا التعامل مع فرز وتصفية البيانات هنا ، وبعدة طرق ، 5. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 6. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبدون أسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 7. يجب النقر هنا حتى نرى نتائج الفرز والتصفية كجزء من الاستعلام في الحقول 8 و 9 ، 8. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 9. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 10. يمكنك عمل استعلام جاهز (للورقة بدون فرز وتصفية) او جدول ، سواء في قاعدة البيانات هذه ، او اختيار قاعدة بيانات خارجية (يجب ان تكون مغلقة حتى تستطيع تصدير استعلام او جدول لها) ، وسيكون اسم الاستعلام نفس اسم الورقة ، مثلا اسم الورقة ABC ، فيصبح اسم الاستعلام: qry_ABC ، او يكون جدول بإسم tbl_ABC حسب اختيارك من الرقم 11 ، او حتى الحاق بيانات الاستعلام الى جدول موجود سابقا (طبعا يجب مراعاة ان يكون الجدول بنفس حقول الورقة) ، 12. لنسخ الاستعلام الى ذاكرة الكمبيوتر ، بحيث يمكنك استعمال لصق ctrl+v لكائن الاستعلام (انظ الفيديو التوضيحي) ، 13. عادة لا نغير اي شيء هنا. طريقة العمل: . نرى من اعلاه: 1. انه تم عمل استعلام ياسم qry_Sheet1 في قاعدة البيانات الخارجة Testing.accdb ، 2. كذلك نسخنا استعلام التصفة الى ذاكرة الكمبيوتر (تابع في الفيديو التالي) . ممكن خلط عمل الفرز و التصفية بعدة طرق ، منها كما في الفيديو اعلاه ، و الصور التاليه . . لنفتح قاعدة البيانات الخارجية ونرى ما فيها ، هنا نحن نتعامل مع استعلام اكسس عادي ، فيمكننا حذف الحقول التي لا نريدها ، او نخفي اخرى ، او .... . عند فتح قاعدة البيانات الخارجية ، وحصلت على رسالة الخطأ هذه ، فهذا معناه ان برنامج "استعلام مسقط" لايزال مفتوح ، وملف الاكسل مفتوح به ، لذا يجب اغلاق برنامج "استعلام مسقط" قبل استعمال ملف الاكسل : . البرنامج يتعامل مع ملف واحد فقط ، ويعمل له استعلام ، واذا اردنا ان نتعامل مع اكثر من ورقة اكسل ، فيمكننا عمل مجموعة من استعلامات ، ثم نعمل امر لتنفيذها واحدة تلو الاخرى ، وبما انه عندنا استعلام ، فيمكننا تحويله الى جميع انواع الاستعلامات ، سواء استعلام الحاق ، او استعلام اضافة ، او استعلام لعمل جدول. هناك عدة ميزات في استعمال هذه الطريقة عن ربط الاكسل كجدول : 1. اسرع بكثير ، 2. عند استيراد كائنات قاعدة البيانات الى قاعدة اخرى ، فالاكسس يتوقف كثيرا عند الجداول الاكسل المرتبطة ، بينما لا يأخذ اي وقت لهذا الاستعلام 3. اختار الحقول اللي تريدها فقط ، جعفر Muscat_Query.zip

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

السلام عليكم ورحمة الله وبركاته 🙂 اليوم يسرني أن أقدم لكم فكرة مبتكرة لتصميم :: الصفحة الرئيسية للبرنامج مع قائمة جانبية متمددة :: بألوان جميلة وتصميم راقي وتحكم شامل بعدد عناصر القائمة والقوائم الفرعية لها 👌 وأهم شي استهلاك أقل كمية من البرمجة والأكواد في التصميم ✌ :: وبدون مقدمات نبدأ على بركة الله :: الفكرة الرئيسة للقائمة الجانبية هي : عمل نموذج فرعي مستمر يستمد بياناته من جدول بحيث أن جميع عناصر القائمة الفرعية عبارة عن سجلات هذا الجدول ، ومن خلال هذا الجدول يتم ترتيب مواقع العناصر من خلال الحقل الرقم Order وكذلك يتم تصنيفها إن كانت زر رئيسي أم فرعي من خلال حقل Main or Sub والأيقونات يتم تخزينها في حقل مرفقات ، وأما الأوامر التي ستنفذها الأزرار فهي مخزنة أيضا في الجدول وهي محصورة في الأوامر التالية ( فتح نموذج - فتح نموذج فرعي - فتح تقرير - فتح تقرير فرعي - إظاهر رسالة نصية) .. والخطوة التي تأتي بعد ذالك هي تصميم النموذج الذي سيضم هذه الأزرار ، ويراعي الترتيب + فرز الأزرار الرئيسية والفرعية في الظهور + التنسيق الشرطي الذي يلون الأزرار بالألوان المناسبة لكل حالة + كود لتنفيذ الأوامر الموكلة للأزرار + .... وهكذا ثم بعد ذلك تصميم نموذج شامل للتحكم بالأزرار .. :: وللاستفادة من هذا الملف :: ستحتاج لهذه العناصر فقط ، ( والباقي كله زيادات لغرض الشرح ) : :: وهنا يأتي شرح يوتيوبي كافي وافي مفصل عن التصميم :: وفيه أيضا فوائد إضافية مثل ( طريقة اختيار أيقونات متناسقة ، وإشارة للنماذج المتطورة الأخرى ) :: تحديثات جديدة :: قمت بتطوير النموذج ليحمل أزرار فرعية وأزرار فرعية من الفرعية بناءا على طلب بعض الإخوة 🙂 كما تم إضافة خاصية إمكانية فتح الماكرو للأزرار .. وكذلك مع إمكانية فتح النماذج والتقارير في وضع التكبير Maximize .. وهذه لوحة التحكم : :: وأخيراا ملف التحميل 🙂 :: ‏‏‏‏Modern Main Page With Main Menue And Sub Sub Btns - Moosak -Maximize-Macro.accdb ملاحظة مهمة : قد لا يعمل هذا النموذج بشكل جيد على النسخ القديمة من 2007 وما قبلها . :: ولا تنسونا من صالح دعواتكم الطيبة 🙂 🌹🌷 ::

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

السلام عليكم تكثر الحاجة الى اخراج تقرير حسب حقول محددة يختارها المستخدم وهذا الباب تم التطرق اليه في هذا المنتدى ومن يبحث يجد الكثير .. علما اني قد استفدت واخذت من تلك المواضيع فما انا الا ناقل . ورب ناقل علم الى من هو اعلم منه . وحتى يكون هذا الموضوع مرجع مختصر لكيفية تصميم واعداد التقرير لذا عملت على اعداد مثال صغير وهو عبارة عن جدول ونموذج وتقرير اولا : عمل قائمة في النموذج يتم فيها عرض حقول الجدول عند تحميل النموذج ... وهذه الاكواد هي المسؤولة : Private Sub Form_Load() Dim dbs As DAO.Database Dim tbl As DAO.TableDef Dim sCaption As String DoCmd.Restore Set dbs = CurrentDb Set tbl = dbs.TableDefs("table1") For Each fld In tbl.Fields sCaption = "" On Error Resume Next sCaption = fld.Properties("Caption") On Error GoTo 0 lstFields.AddItem fld.Name & ";" & sCaption Next fld Set dbs = Nothing Set tbl = Nothing End Sub ثانيا عملت زر لإعداد الحقول في التقرير ثم فتحه ، وخلف هذا الزر يتم تنفيذ هذه الشفرة Dim i As Integer Dim txt As TextBox Dim lbl As Label Dim intSelectedCount As Integer Dim lngWidth As LoadPictureConstants Dim intSelectedNo As Integer With lstFields If .ItemsSelected.Count = 0 Then MsgBox "يجب اختيار حقل واحد على الأقل", vbExclamation, "خطأ" Exit Sub End If DoCmd.OpenReport "Rep1", acViewDesign, , , acHidden intSelectedCount = .ItemsSelected.Count lngWidth = Reports("Rep1").Width / intSelectedCount Reports("Rep1").Section("PageHeaderSection").Height = 310 Reports!Rep1!Label2.Caption = Nz(Me.Textlabl) Reports("Rep1").Section("Detail").Height = 310 intSelectedNo = 0 For i = 0 To .ListCount - 1 If .Selected(i) Then Set lbl = CreateReportControl("Rep1", acLabel, acPageHeader, , , intSelectedNo * (lngWidth + 50), 5, lngWidth, 300) lbl.Caption = .Column(1, i) lbl.BackStyle = 1 lbl.BackColor = RGB(200, 200, 200) lbl.BorderStyle = 1 lbl.FontBold = True lbl.TextAlign = 2 Set txt = CreateReportControl("Rep1", acTextBox, acDetail, , .Column(0, i), intSelectedNo * (lngWidth + 50), 5, lngWidth, 300) txt.BorderStyle = 1 txt.TextAlign = 2 intSelectedNo = intSelectedNo + 1 End If Next i End With DoCmd.OpenReport "Rep1", acViewReport ملحوظات : جعلت زر الخروج في التقرير يغلق التقرير ( من غير حفظ ) متجاوزا رسالة تأكيد الحفظ حفظ التقرير يسبب تراكم الحقول المصنوعة داخل الكود .. ومن ثم تظهر المشكلات والأخطاء ختاما لا تنسوني من دعواتكم الصالحة واتمنى ان تجدوا فيه الفائدة والمتعة اختيار حقول التقرير.rar

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) اليوم جئتكم بفكرة جديدة وأعتقد أنه لم يسبقني أحد بهذا الطريق ؛ وهو إضافة اختيار واجهة اللغة إلى تطبيقات وبرامج ومشاريع الآكسيس بطريقة جديدة وتقدروا تقولوا 2024 في البداية سأقوم بشرح المطلوب داخل القاعدة التي سيتم التطبيق عليها ، أولاً :- جدول واحد فقط يحتوي على حقل واحد فقط أيضاً وسنسميه بـ SettingsTable ، والحقل الذي بداخله هو Language من نوع نصي ( Text ) . ثانياً :- نموذج Settings وهو طبعاً ليس له مصدر سجلات . وبداخله كومبوبوكس Combo box سيكون اسمه cboLanguage نوع مصدر بياناته Value List ؛ ومصدر بياناته القيم التالية ( "العربية";"English" ) . ثالثاً :- بجانب قاعدة البيانات سنقوم بإنشاء مجلد جديد وسيتم تسميته بـ Language . الآن خطوات العمل :- الموديول Module :- قم بإنشاء Module جديد وسمه بـ Set_Language ؛ وهو مفتاح العمل والذي من خلاله سنعتمد على جلب الترجمة من الملفات التي سنقوم بإنشائها لاحقاً . وهذا الكود مع الشرح الكامل له بين السطور . Option Compare Database Option Explicit ' المتغير العام لتخزين اللغة الحالية Public CurrentLanguage As String ' تحديث اللغة الحالية Public Sub UpdateLanguage() On Error Resume Next ' احصل على اللغة المحددة من جدول الإعدادات CurrentLanguage = DLookup("Language", "SettingsTable") ' قم بتحديث العلامات في جميع النماذج UpdateLabelsInAllForms End Sub ' تحديث العلامات في جميع النماذج Private Sub UpdateLabelsInAllForms() Dim frm As AccessObject ' تحديث العلامات في جميع النماذج المحملة For Each frm In CurrentProject.AllForms If frm.IsLoaded Then UpdateLabelsInForm Forms(frm.Name) End If Next frm End Sub ' تحديث العلامات في نموذج محدد Private Sub UpdateLabelsInForm(frm As Object) Dim arFile As String, enFile As String Dim arLabels() As String, enLabels() As String Dim i As Integer ' احصل على ملف اللغة العربية واللغة الإنجليزية arFile = GetLanguageFilePath("Arabic.txt") enFile = GetLanguageFilePath("English.txt") ' اقرأ الملفات واملأ المصفوفات بالنصوص المترجمة arLabels = Split(ReadFile(arFile), vbCrLf, -1) enLabels = Split(ReadFile(enFile), vbCrLf, -1) ' قم بتحديث العلامات في النموذج For i = 0 To UBound(arLabels) UpdateLabel frm, "Label" & CStr(i + 1), arLabels(i), enLabels(i) UpdateLabel frm, "Command" & CStr(i + 1), arLabels(i), enLabels(i) Next i End Sub ' احصل على مسار قاعدة البيانات الحالية Private Function GetDatabasePath() As String Dim dbPath As String dbPath = CurrentDb.Name GetDatabasePath = Left(dbPath, InStrRev(dbPath, "\")) End Function ' احصل على مسار ملف اللغة Private Function GetLanguageFilePath(fileName As String) As String GetLanguageFilePath = GetDatabasePath() & "Language\" & fileName End Function ' اقرأ ملف النص وارجع النص كنص نصي Private Function ReadFile(filePath As String) As String Dim fileNumber As Integer fileNumber = FreeFile Open filePath For Input As fileNumber ReadFile = Input$(LOF(fileNumber), fileNumber) Close fileNumber End Function ' تحديث علامة محددة في النموذج بناءً على اللغة الحالية Private Sub UpdateLabel(frm As Object, labelName As String, arabicText As String, englishText As String) On Error Resume Next ' قم بتحديث العلامة بناءً على اللغة الحالية frm.Controls(labelName).Caption = IIf(CurrentLanguage = "العربية", arabicText, englishText) On Error GoTo 0 End Sub * ملاحظة :- سنعتمد هنا على طريق بسيط جداً وهو المسميات في النماذج ، فمثلاً لو انشأنا زر في نموذج ما وكانت تسميته Caption هي حفظ وكان اسم الزر Command1 ؛ فعند الترجمة سيصبح كل زر في البرنامج باسم Command1 هو بمثابة زر الحفظ وستكون ترجمته Save ؛ لذا سنعتمد طريقة توحيد المسميات في النماذج وهذا سيجعل الأمر سهلاً جداً للصيانة ، وطبعاً لا يمكن أن يكون لعنصرين ( كائنين ) في النموذج لهما نفس الإسم . رابعاً :- العودة إلى نموذج Settings الذي تم التحدث عنه في النقطة ( ثانياً ) ؛ سنقوم بدايةً باستكمال إنشاء الأكواد الخاصة بتغيير اللغة ، قبل الأحداث للـ Combo Box والنموذج . سنقوم بإدراج هذه الأكواد الثلاثة البسيطة :- ' تحديث العناصر في النموذج بناءً على اللغة المختارة Private Sub UpdateLanguageForControls() On Error Resume Next Dim ctrl As AccessObject For Each ctrl In Me.Controls ' يمكنك هنا إضافة العناصر الأخرى التي تريد تحديثها بناءً على اللغة ' مثلا: If TypeOf ctrl Is ComboBox Then Next ctrl End Sub ' حفظ اختيار اللغة في جدول SettingsTable Private Sub SaveLanguageChoice() CurrentDb.Execute "UPDATE SettingsTable SET Language='" & Me.cboLanguage & "'" End Sub ' تغيير اللغة وتحديث العناصر ذات الصلة Private Sub ChangeLanguage(selectedLanguage As String) CurrentDb.Execute "UPDATE SettingsTable SET Language='" & selectedLanguage & "'" UpdateLanguageForControls End Sub وفي حدث عند الفتح للنموذج سنقوم بإدراج هذا الكود :- ' حدث يتم تنفيذه عند فتح النموذج Private Sub Form_Open(Cancel As Integer) UpdateLanguage End Sub وفي حدث عند التحديث للكومبوبوكس سندرج الكود التالي :- ' حدث يتم تنفيذه بعد تحديث اختيار اللغة من ComboBox Private Sub cboLanguage_AfterUpdate() Dim response As VbMsgBoxResult Dim Language As String ' احصل على اللغة المحددة من ComboBox Language = Me.cboLanguage.Value ' قم بتحديد الرسالة بناءً على اللغة المختارة If Language = "العربية" Then response = MsgBox("هل ترغب في تغيير اللغة إلى العربية؟", vbQuestion + vbYesNo, "التأكيد") ElseIf Language = "English" Then response = MsgBox("Do you want to change the language to English?", vbQuestion + vbYesNo, "Confirmation") End If ' قم باتخاذ الإجراء المناسب بناءً على رد المستخدم If response = vbYes Then SaveLanguageChoice Application.Quit Else SaveLanguageChoice DoCmd.Close End If End Sub الآن نأتي لأهم نقطة في هذا الموضوع ، ألا وهي . أين ستكون الترجمة ؟ طبعاً قمنا سابقاً بإنشاء المجلد Language بجانب قاعدة البيانات ، الآن سنذهب إليه وسنقوم بإنشاء ملفين نصيين Text الأول Arabic.txt ، والثاني English.txt . في الأعلى افترضنا انه لدينا في النموذج زر اسمه Command1 والـ Caption له كانت حفظ ، الآن سنقوم بكتابة المسمى بالعربي وهو حفظ في ملف النص Arabic ، وفي الملف الثاني English سنكتب Save وهو أول أمر قمنا به كتجربة ( لاحظ أن Command يتبعها الرقم 1 ) وعليه فأن أي مسمى Command1 في أي نموذج سيكون اسمه حفظ أو Save عند اختيار الإنجليزية . وفي النهاية سأترك مرفق يحتوي تطبيق لما تحدثنا به سابقاً . والمتابعة لأي استفسار أو توضيح Change Language.zip

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكنها بالحديثة و بطريقة فوكشية ▫▪◽◾◻◼. الكثير من المواضيع التي تحدثت عن كيفية رفع ملفات المستخدم على جوجل درايف أو غيره من المواقع التي تقدم مساحات سحابية متعددة الخدمات لمستخدميها .. اليوم وبتوفيق من الله ، تم إنشاء هذه الأداة للتعامل مع جوجل درايف Google Driveحصراً ، لكونه يقدم مساحة 15 جيجا بايت لمستخدميه . ما كان يؤرق الكثيرين هو أن جوجل أو غيره من مقدمي الخدمة المشابهة يقوم بتعديل سياسته وقوانينه كل فترة . لكن هنا وبهذه الأداة المجانية تم حل المشكلة بعد فحصها مراراً وتكراراً (متمنياً ذلك) . الفكرة في الأداة تعتمد على حساب جوجل أو Gmail شخصي . ما يلزم المستخدم هنا تطبيق الخطوات البسيطة التالية حسب الصور أو الفيديو في هذا الرابط . 📌 عند فتح الأداة لأول مرة ، سيساعدك معالج الإنشاء بجميع الخطوات ( خطوة بخطوة ) وستظهر لك هذه الرسالة :- 📌 عند النقر على Yes ، ستظهر لك رسالة الإرشاد الأولى كالتالي :- 📌 سيتم فتح المتصفح لديك على الرابط الخاص بإنشاء الخدمة .. وللمتابعة دون الإطالة ، أترككم مع الصور و الخطوات خطوة بخطوة . 📌 عند الإنتهاء من تنفيذ الخطوات والحصول على رمزي الـ ( CLIENT ID و CLIENT SECRET ) . ✨ سيتوجه بك معالج الإنشاء للخطوة قبل الأخيرة كالآتي :- 📌 هنا يطلب منك لصق رمز CLIENT ID الذي حصلت عليه من تسلسل الخطوات السابقة . ثم بعد لصقه والضغط على OK ، ستظهر لك الرسالة التالية :- 📌 والتي يطلب منك لصق CLIENT SECRET كما في الصورة أعلاه . ✨ الآن الخطوة الهامة والتلقائية ، وبعد لصق الرمزين الخاصين بحسابك في جوجل درايف ( لا تقم بمشاركتهم مع أي أحد ) ، سنهب للحصول على رمز التفويض مرة واحدة فقط ! وهذا يعني أنك لن تحتاج إليه مستقبلاً . انظر الصورة التالية :- 📌 عند النقر على موافق ، سيتم فتح متصفحك على رابط خاص في جوجل لتمنح بريدك الإلكتروني الذي استخدمته في إنشاء الخدمة سابقاً كامل الصلاحية لإستخدام خدمات جوجل درايف . وطبعاً بالمتابعة وتأكيد الموافقة ، ستحصل على رمز التفويض الخاص بك و لمرة واحدة فقط ولن تحتاجه فيما بعد ، فتقوم بنسخه ولصقه في رسالة التأكيد التالية :- الآن وبفضل الله ، ستظهر لك رسالة " تم التفويض بنجاح" ، وبهذه الخطوة تم ربط آكسيس بحساب جوجل درايف الخاص بك ، وستظهر لك واجهة الأداة كما في الصورة أدناه . وما يلي شرحاً سريعاً لمميزاتها . مميزات الأداة :- تتيح لك الأداة رفع الملفات بأي امتداد وبأي حجم ؛ إلى أي مجلد تحدده في حسابك على جوجل درايف ، أو في الملف الرئيسي عند عدم اختيارك لمجلد محدد . والمجلدات التي في حسابك ستظهر لك عند النقر على زر "مجلداتي" ، ثم من قائمة الكومبوبوكس ستختار المجلد الهدف لرفع الملف اليه . زر "إختيار ملف" لإختيار الملف الذي ترغب برفعه على جوجل درايف . زر "معاينة" مخصص لمعاينة الملف حسب الرسالة التي ستظهر لك . زر "مسح الحقول" لتفريغ العناصر من قيمها . زر "ارفع الملف" والذي من خلاله ستقوم بتنفيذ عملية رفع الملف إلى حسابك في جوجل درايف . بعد إتمام عملية الرفع بنجاح ، يتم عرض المساحة المستخدمة من المساحة التخزينية لحسابك ( وهي 15 جيجا ) ، والنسبة المئوية للمساحة في عنوان النموذج ، كما في الصورة أدناه لعملية الرفع . زر "نسخ الرابط" لنسخ الرابط بعد أن تمت عملية الرفع بنجاح ( لإستخداماتك الشخصية وحاجتك لاحقاً ) . وفيما يلي ، صورة سريعة لعملية رفع صورة على سبيل المثال : ملف الأداة بنسختين .. نسخة 64 بت نسخة 32 بت Uploader.zip Uploader 32.zip

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. وستلاحظون اني استخدمت الدالة DateSerial ، حتى اعطي اليوم والشهر والسنة بياناتهم يدويا ، بدلا عن استعمال CDate . هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) بالإشارة الى الموضوع الذي أعلنت عنه سابقاً في هذا الرابط هنا ، اسمحوا لي بأن أطرح هذه الفكرة الجديدة والتي تم تجربتها مراراً وتكراراً إلى أن خرجت بهذه النتيجة فيما يتعلق بموضوع التحديث الهوائي أو Online أو OTA ( Over-The-Air ) . الموضوع بداية بسيط جداً ولن يحتاج تعقيد في تنفيذ هذه الطريقة . حيث ما يلزمنا أولاً هو حساب على Google Drive ( لماذا ؟ = لأن 95 % من الأشخاص عندهم هذا الحساب ) . و حساب على موقع Dropbox ( لماذا ؟ = لأنه يعطينا امكانية التحميل برابط مباشر خلافاً في جوجل درايف ) وهو ما يميزه عن Google Drive . بناءً على ما سلف ، نبدأ شرح الخطوات والمتطلبات على بركة الله :- 1. سنحتاج جدول واحد مرفق وهو ( Settings ) ، ولا أنصح بالتلاعب به ما لم يكن على أساس صحيح ؛ ويحتوي على الحقول التالية :- الحقل Ver = رقمي = لتحديد الإصدار الحالي للنسخة الحالية في قاعدة البيانات الحالية. الحقل Link = نصي = لتحديد رابط الملف النصي الذي سيتم قراءة الإصدار الجديد منه ومقارنته مع قيمة الحقل Ver لتحديد ما اذا كان هناك نسخة جديدة أم لا . الحقل URLS = نصي = سيتم ادراج رابط التحميل للإصدار الجديد من خلال الكود تلقائياً. الحقل DBName = نصي = سيمكانك هنا من تحديد اسم قاعدة البيانات التي سيتم حفظ التحديث الجديد بها . وهنا لتسهيل فكرة اسم القاعدة القديمة واستبدالها بالنسخة الجديدة سيتم جلب القيمة تلقائياً . الحقل Auto_Check = نوع Yes/No = لتفعيل ميزة الفحص التلقائي للتحديثات ( فكرة شبيهة بتلك التي في أجهزة الجوال والمحمول عند تفعيلها يصلك إشعارك بوجود نسخة جديدة إن كانت الميزة مفعلة طبعاً ) 2. تحميل الإصدار الجديد على موقع Dropbox ونسخ رابط الملف ( مع التأكد أن الملف عند مشاركته قد تمت مشاركته للجميع - الموقع يجعلها قيمة افتراضية - ولكن للتأكيد ) . 3. ملف نصي واحد ( TxT. ) سميه ما شئت وهو ثابت غير قابل للتبديل ، ويكون محتواه ما يلي :- السطر الأول نضع رقم الإصدار الجديد . اي انه في الملف القديم لنفترض ان قيمة الحقل Ver = 0.1 . هنا في الملف النصي سنضع الإصدار الأحدث أي مثلاً ( 0.2 ). السطر الثاني نضع رابط النسخة الحديثة التي تم رفعها على Dropbox في النقطة السابقة 2 . أي انه سيكون لدينا ملف نصي يحتوي سطرين الأول رقم الإصدار الحديث والذي ستتم قراءته و مقارنته مع الحقل Ver في الإصدار الذي لدى العميل ، والسطر الثاني رابط النسخة الأحدث من دروب بوكس . 4. سنقوم برفع هذا الملف النصي على جوجل درايف ( السبب : دروب بوكس لم يدعم فكرة قراءة الملف النصي وجلب قيمة رقم الاصدار في السطر الأول لمقارنتها مع القيمة في النسخة التي لدى العميل في الحقل Ver ) . 5. ثم سنقوم بنسخ الرابط لهذا الملف النصي ومشاركته للجميع - أو بمعنى آخر لمن يملك الرابط - ولصقه في الجدول الثابت Settings في الحقل Link وهو هنا سيكون أيضاً قيمة ثابتة لن تتغير . أي أنك ستقوم بتغيير فقط رقم الإصدار في النسخة الجديدة في الحقل Ver . وإعادة رفع الملف النصي بعد تحديث قيمة رقم الاصدار الجديد فقط . طبعاً هنا بالإفتراض جدلاً وبعد تجربة متكررة أنه عندما تقوم برفع ملف موجود مسبقاً على أي موقع من ( جوجل درايف أو دروب بوكس ) فأن العنوان لهذا الملف لن يتغير لأنه سيتم استبدال الملف القديم بالجديد . ( وهي نقطة جيدة استفدنا منها لصالحنا ). 6. الآن الفكرة بشكل عام واضحة ولا تحتاج لتعقيد في الشرح ( وأي فكرة أو طريقة في البداية ستحتاج مرات معدودة لتصبح سهلة في تطبيقها عن ظهر قلب ) الآن وما هو مهم للجميع ، الكود التالي للمديول :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '*************** ( 28/12/2024 ) *************** Option Compare Database Option Explicit Public Function IsInternetConnected() As Boolean On Error GoTo ErrorHandler Dim xhr As Object Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0") xhr.SetOption 2, 13056 xhr.Open "GET", "https://www.google.com", False xhr.send IsInternetConnected = (xhr.Status = 200) Set xhr = Nothing Exit Function ErrorHandler: IsInternetConnected = False If Not xhr Is Nothing Then Set xhr = Nothing End Function Public Function ConvertGoogleDriveLink(ByVal originalLink As String) As String On Error GoTo ErrorHandler Dim FileID As String If InStr(1, originalLink, "/d/") > 0 Then FileID = Mid(originalLink, InStr(1, originalLink, "/d/") + 3) FileID = Left(FileID, InStr(1, FileID, "/") - 1) ElseIf InStr(1, originalLink, "id=") > 0 Then FileID = Mid(originalLink, InStr(1, originalLink, "id=") + 3) If InStr(1, FileID, "&") > 0 Then FileID = Left(FileID, InStr(1, FileID, "&") - 1) End If End If If Len(FileID) > 0 Then ConvertGoogleDriveLink = "https://drive.google.com/uc?id=" & FileID Else ConvertGoogleDriveLink = originalLink End If Exit Function ErrorHandler: ConvertGoogleDriveLink = originalLink End Function Public Function CheckForUpdate() As Boolean On Error GoTo ErrorHandler Dim currentVer As Double Dim onlineVer As Double Dim xhr As Object Dim onlineContent As String Dim driveLink As String Dim contentLines() As String Dim updateURL As String Dim currentDBName As String currentDBName = CurrentDb.Name currentDBName = Mid(currentDBName, InStrRev(currentDBName, "\") + 1) currentDBName = Left(currentDBName, InStrRev(currentDBName, ".") - 1) CurrentDb.Execute "UPDATE Settings SET DBName = '" & Replace(currentDBName, "'", "''") & "'" currentVer = DLookup("Ver", "Settings") If Not IsInternetConnected() Then Forms!Frm_Index!Lbl_Load.Caption = "أنت تستخدم الإصدار: " & currentVer CheckForUpdate = False Exit Function End If driveLink = ConvertGoogleDriveLink(DLookup("Link", "Settings")) Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0") xhr.SetOption 2, 13056 xhr.Open "GET", driveLink, False xhr.setRequestHeader "User-Agent", "Mozilla/5.0" xhr.send If xhr.ReadyState = 4 Then If xhr.Status = 200 Then onlineContent = Trim(xhr.responseText) contentLines = Split(onlineContent, vbCrLf) If UBound(contentLines) >= 1 Then onlineVer = Val(contentLines(0)) updateURL = Trim(contentLines(1)) If onlineVer > 0 Then If onlineVer > currentVer Then CurrentDb.Execute "UPDATE Settings SET URLS = '" & updateURL & "'" Forms!Frm_Index!Lbl_Load.Caption = " تحديث جديد متوفر الآن : " & onlineVer & " Ver - انقر للتحميل " Forms!Frm_Index!ImgUpdate.Visible = True CheckForUpdate = True Forms!Frm_Index!Tx_User.Enabled = True Forms!Frm_Index!Tx_Pass.Enabled = True Forms!Frm_Index!Tx_User.SetFocus Else Forms!Frm_Index!Lbl_Load.Caption = "أنت تستخدم أحدث إصدار : " & onlineVer & " Ver " Forms!Frm_Index!Tx_User.Enabled = True Forms!Frm_Index!Tx_Pass.Enabled = True Forms!Frm_Index!Tx_User.SetFocus End If End If End If End If End If Set xhr = Nothing Exit Function ErrorHandler: CheckForUpdate = False If Not xhr Is Nothing Then Set xhr = Nothing End Function Sub UpdateURLSAndOpenNewDatabase() Dim UrlValue As String, NameValue As String Dim TargetDb As DAO.Database Dim rs As DAO.Recordset Dim CurrentDbPath As String Dim NewDbPath As String CurrentDbPath = CurrentProject.Path & "\" & Dir(CurrentProject.FullName) NewDbPath = CurrentProject.Path & "\Data\Update.accdb" If Dir(CurrentProject.Path & "\Data\Update.Dll") <> "" Then Name CurrentProject.Path & "\Data\Update.Dll" As NewDbPath Else MsgBox "الملف Update.Dll غير موجود", vbCritical Exit Sub End If On Error GoTo ErrorHandler UrlValue = Nz(CurrentDb.OpenRecordset("SELECT URLS FROM Settings").Fields("URLS").Value, "") NameValue = Nz(CurrentDb.OpenRecordset("SELECT DBName FROM Settings").Fields("DBName").Value, "") If UrlValue = "" Or NameValue = "" Then MsgBox "خطأ في تحميل التحديث", vbCritical Exit Sub End If Set TargetDb = DBEngine.OpenDatabase(NewDbPath) Set rs = TargetDb.OpenRecordset("Settings", dbOpenDynaset) If rs.EOF Then rs.AddNew rs.Fields("URLS").Value = UrlValue rs.Fields("DBName").Value = NameValue rs.Update Else rs.MoveFirst rs.Edit rs.Fields("URLS").Value = UrlValue rs.Fields("DBName").Value = NameValue rs.Update End If rs.Close TargetDb.Close Shell "msaccess.exe """ & NewDbPath & """", vbNormalFocus Application.Quit Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close If Not TargetDb Is Nothing Then TargetDb.Close Exit Sub End Sub Public Function ExtractAttachmentFile() As Boolean On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim rsAttach As DAO.Recordset2 Dim fld As DAO.Field2 Dim dataFolder As String dataFolder = CurrentProject.Path If Dir(dataFolder, vbDirectory) = "" Then MkDir dataFolder End If Set db = CurrentDb Set rs = db.OpenRecordset("Settings") If Not rs.EOF Then Set fld = rs.Fields("DBFiles") If Not IsNull(fld) Then Set rsAttach = fld.Value If Not rsAttach.EOF Then rsAttach.Fields("FileData").SaveToFile dataFolder & "\" & rsAttach.Fields("FileName").Value ExtractAttachmentFile = True End If rsAttach.Close End If End If CleanUp: If Not rs Is Nothing Then rs.Close Set rs = Nothing Set db = Nothing Exit Function ErrorHandler: ExtractAttachmentFile = False Resume CleanUp End Function وما يلي كود النموذج لجميع الأجزاء والمكونات داخله :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '*************** ( 28/12/2024 ) *************** Option Compare Database Option Explicit Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private bMessage20Displayed As Boolean Private bMessage35Displayed As Boolean Private bMessage50Displayed As Boolean Private LoginAttempts As Integer Dim TimeCount As Long Private Sub Btn_Quit_Click() Dim userResponse As VbMsgBoxResult userResponse = MsgBox("إغلاق النظام؟", _ vbYesNo + vbInformation + vbMsgBoxRight, "تأكيد عملية الإغلاق") If userResponse = vbYes Then DoCmd.Quit ElseIf userResponse = vbNo Then DoCmd.CancelEvent End If End Sub Private Sub Form_Load() ExtractAttachmentFile LoginAttempts = 0 Me.Caption = "Foksh - Officena.Net - 2025" DoEvents If Check_Auto = -1 Then Me.TimerInterval = 1000 Else Me.TimerInterval = 0 Me.Lbl_Load.Caption = "" End If End Sub Private Sub Form_Timer() Me.TimerInterval = 0 CheckForUpdate End Sub Private Sub ImgUpdate_Click() On Error GoTo ErrorHandler Dim userResponse As VbMsgBoxResult userResponse = MsgBox("التحديث الآن؟", _ vbYesNo + vbInformation + vbMsgBoxRight, "تأكيد عملية التحديث") If userResponse = vbYes Then UpdateURLSAndOpenNewDatabase ElseIf userResponse = vbNo Then DoCmd.CancelEvent End If ErrorHandler: Resume Next End Sub ما يتم تنفيذه عند استعمال الفكرة :- أولاً عند الفتح للمشروع سيتم استخراج ملف DLL مرفق داخل قاعدة البيانات . ثانياً عند اكتمال التحديث سيتم استبدال النسخة القديمة بالنسخة الجديدة ، وشأنه شأن أي عملية تحديث ؛ فإنك ستفقد النسخة القديمة كاملةً ( وهنا الحاجة الماسة لاعتماد فكرة تقسيم قاعدة البيانات ) . ملف الواجهة المرفق مفتوح المصدر 👈 [ Main.accdb ] * عذراً إن كانت طريقتي في العمل مزعجة أو غريبة نوعاً ما ، لكن هو طبعي 😅 . فماذا أفعل ؟؟!!

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كثير منا يبحث عن QR ( رمز إستجابة سريعة ) ولكن ملوّن !! ونستطيع التحكم باللون حسب حاجته !! اليوم بطريقة بسيطة يتم تنفيذها بكل سلاسة سنحقق ذلك . والفائدة على سبيل المثال :- الإبتعاد عن النمط التقليدي اللون الأسود المعروف به رمز الـ QR .. شكل جمالي ملفت لرمز الإستجابة QR .. التمييز بين الأقسام أو الأستخدام للـ QR حسب حاجة المشروع . فمثلاً ( قسم المحاسبة لهم رمز باللون الأزرق ، قسم الصيانة لهم رمز باللون الأسود ، المعلمين رمز باللون الأحمر ..... إلخ . والكثير من الإستخدامات التي لا تخطر ببالي حالياً . تأكد من تثبيت إصدار NET Framework 4.0 أو أعلى على جهازك . تستطيع التحميل من هذا الرابط ، أو بشكل مباشر من هذا الرابط . برنامج ImageMagick . ويمكنك تحميله من رابط الموقع من هذا الرابط ، أو بشكل مباشر من هذا الرابط . ملفات الـ DLL ( zxing.interop.dll ، zxing.dll ، zxing.interop.tlb ) والتي هي مكتبات سيتم إضافتها الى محرر الأكواد VBA في آكسيس لاحقاً طريقة التثبيت والإضافة ( موجودة في الملف المرفق ) . أولا يلزمنا تسجيل المكتبات المستخدمة في المشروع ( وهنا سنستخدم ZXing لتنفيذ مهمتنا ) وطبعاً سنحتاج مكتبة QRCode ، ويجب تسجيلها ليتم إضافتها في آكسيس في مكتبات الـ VBA > Tools > References . فكيف ننفذ هذه الخطوة المهمة . بعد التأكد من تثبيت المستلزمين السابقين :- افتح موجه الأوامر CMD كمسؤول ( Run as Administrator ) . قم بكتابة السطر التالي لتسجيل المكتبة :- cd C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك قم بكتابة السطر التالي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase zxing.interop.dll ومن المفترض أن تظهر معك النتيجة بهذا الشكل :- أما خلاف ذلك فأن عملية تسجيل المكتبة لم تنجح ولن يتم إضافتها إلى محرر الأكواد VBA كما نريد . الآن لاستكمال عملية تسجيل المكتبة وإضافتها الى محرر الأكواد VBA ، نطبق آخر خطوة وهي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase "C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.dll" /tlb:"C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.tlb" --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\ Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك الآن نفتح قاعدة بيانات جديدة ، ونذهب إلى محرر الأكواد ( Tools > References ) ، ونبحث عن المكتبة التالية كما في الصورة :- الآن وبعد إتمام عملية التسجيل للمكتبة المطلوبة وتثبيت المستلزمات السابقة ، نقوم بإنشاء نموذج يحتوي على مربع نص ، وعنصر صورة ، و زر لتنفيذ العملية . ثم نأتي إلى الأكواد ، وما سنحتاجه الآن هو مديول يحتوي على الدالتين التاليتين :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit #If VBA7 Then Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Function Encode_To_QR_Code_To_File(str As String, Optional foregroundColor As String = "black", Optional backgroundColor As String = "white") As String On Error GoTo ErrorHandler Dim writer As IBarcodeWriter Dim qrCodeOptions As QrCodeEncodingOptions Dim filepath As String Dim folderPath As String folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If filepath = folderPath & "\QRCode_" & Format(Now, "yyyyMMdd_hhmmss") & ".png" Set qrCodeOptions = New QrCodeEncodingOptions Set writer = New BarcodeWriter writer.Format = BarcodeFormat_QR_CODE Set writer.Options = qrCodeOptions qrCodeOptions.Height = 200 qrCodeOptions.Width = 200 qrCodeOptions.CharacterSet = "UTF-8" qrCodeOptions.Margin = 1 qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H writer.WriteToFile str, filepath, ImageFileFormat_Png If Change_QR_Code_Colors_ImageMagick(filepath, foregroundColor, backgroundColor) Then Encode_To_QR_Code_To_File = filepath Else Encode_To_QR_Code_To_File = "" End If Exit Function ErrorHandler: Encode_To_QR_Code_To_File = "" MsgBox "حدث خطأ أثناء إنشاء QR Code: " & Err.Description, vbCritical, "خطأ" End Function Function Change_QR_Code_Colors_ImageMagick(filepath As String, foregroundColor As String, backgroundColor As String) As Boolean On Error GoTo ErrorHandler Dim batchFilePath As String Dim batchContent As String Dim result As Long If Dir(filepath) = "" Then MsgBox "لم يتم العثور على الملف: " & filepath, vbCritical, "خطأ" Exit Function End If batchContent = "@echo off" & vbCrLf & "magick " & Chr(34) & filepath & Chr(34) & " -fill " & foregroundColor & " -opaque black -fill " & backgroundColor & " -opaque white " & Chr(34) & filepath & Chr(34) batchFilePath = Environ$("temp") & "\ChangeQRColors.bat" Open batchFilePath For Output As #1 Print #1, batchContent Close #1 result = Shell("powershell -Command Start-Process " & Chr(34) & batchFilePath & Chr(34) & " -Verb RunAs", vbHide) DoEvents Sleep 3000 If Dir(filepath) <> "" Then Change_QR_Code_Colors_ImageMagick = True Else Change_QR_Code_Colors_ImageMagick = False End If Kill batchFilePath Exit Function ErrorHandler: Change_QR_Code_Colors_ImageMagick = False MsgBox "حدث خطأ أثناء تغيير ألوان QR Code: " & Err.Description, vbCritical, "خطأ" End Function وفي حدث عند النقر لزر التنفيذ ، الكود التالي :- Private Sub Command20_Click() Dim imagePath As String Dim folderPath As String If IsNull(Me.Text0) Or Me.Text0 = "" Then MsgBox "QR Code الرجاء إدخال نص لإنشاء", vbExclamation, "" Exit Sub End If Dim foregroundColor As String Dim backgroundColor As String foregroundColor = "Blue" backgroundColor = "white" imagePath = Encode_To_QR_Code_To_File(Me.Text0, foregroundColor, backgroundColor) If imagePath <> "" Then Me.Image0.Picture = imagePath MsgBox " بنجاح QR Code تم إنشاء", vbInformation, "" folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" Else MsgBox "فشل في إنشاء QR Code", vbCritical, "" End If End Sub الآن لتغيير ألوان الـ QR كخلفية أو لون الرمز نفسه ، تستطيع التعديل من خلال السطرين التاليين في زر التنفيذ :- foregroundColor = "Blue" <---- هنا لون الرمز نفسه backgroundColor = "white" <---- هنا لون الخلفية وهنا نكون قد وضحنا المطلوب وطريقة تنفيذه خطوة بخطوة .. QrCodeZXing.zip

ومشاركة مع استاذى واخى الحبيب الاستاذ @Foksh طريقتى المتواضعة zint barcode generator V2.zip

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة لأنشاء الجداول بطريقة مختلفة عن الطريقة التقليدية التي نعرفها .. إلا أنها ما زالت قيد التطوير الفكرة تعتمد على نموذج واحد فقط يمكّن المستخدم من إنشاء جداوله والحقول التي تحتويها ونوع الحقول بشكل سهل وبسيط . أولاً انقر على الزر " أنشاء حقل جديد ... " ثانياً قم بملئ الحقول ( اسم الجدول ، اسم الحقل ، نوع الحقل ) ، عند اختيار نوع الحقل سيتم إضافة الحقل الجديد الى الـ List Box تسلسلاً حسب الإدخال . عند الإنتهاء من إدخال جميع الحقول وأنواعها ، انقر الزر " إنشاء الجدول ... " ، وهنا سيتظهر رسالة تفيد بأنه ( لابد من وجود حقل مفتاح أساسي ، هل ترغب بتعيين حقل مفتاح أساسي ؟ ) عند اختيار Yes - نعم سيتم تعيين أول حقل كمفتاح أساسي ؛ وإذا تم اختيار No - لا سيتم انشاء الجدول دون مفتاح أساسي . عند إنشاء الجدول سيتم تصحيح عدة نقاط بشكل تلقائي وهي :- إزالة المسافة من اسماء الجداول واستبدالها بـ " _ " . إضافة الجزء "_Tbl" الى اسم الجدول عند انشائه . أيضاً إزالة المسافة من أسماء الحقول واستبدالها بـ " _ " . الملف مفتوح المصدر TBL Maker.accdb بناءً على إقتراحات أستاذي وصديقي @Moosak ، والتعديلات التي تقدم بها صديقي وأستاذي @ابو جودي ، تم دمج وإضافة تعديلات جديدة أرجو أن تنال رضاكم وإعجابكم . تم إضافة ميزة أن يكون في الجدول أكثر من حقل مفتاح أساسي . تم إضافة ميزة التعديل على الحقول أو حذف أحد الحقول قبل إنشاء الجدول من خلال زر " تعديل الحقول " ، وبعد إجراء التعديلات انقر زر " تأكيد التعديل ". تم دمج ميزة حرية إضافة " _Tbl " الى اسم الجدول عند انشائه ( فكرة الأستاذ أبو جودي مع إجراء تعديل بسيط ) - إختياري . تم دمج ميزة أن يكون أسماء الجداول والحقول ( الإنجليزية ) تبدأ بحرف كبير Capital Letter . تم إضافة ميزة فتح الجدول بعد انشائه لرؤية النتيجة أو لإدخال البيانات - إختياري . تم إضافة زر " مفتاح أساسي " لتمكين المستخدم من اختيار الحقول التي يريدها أن تكون مفتاح أساسي . تم إضافة زر " إضافة حقل " لإضافة حقل جديد . تم تعديل التصميم بشكل بسيط ليتناسب مع محتوياته والميزات الجديدة . ✔ لا حاجة لأي مكتبات أو مديولات عند نسخ النموذج لمشروعك والبدء بالإستفادة من ميزاته . ✔ أتطلع لأي أفكار جديدة أو اقتراحات TBL Maker.accdb680 kB · 7 downloads تم إضافة نموذج لإنشاء العلاقات من خلال البرنامج بشكل بسيط بحيث :- يتم اختيار الجدول الأول ، ثم الحقل الذي نرغب بانشاء علاقة له ، ثم اختيار الجدول الثاني وكذلك الأمر اختيار الحقل الثاني الذي سيكون على علاقة مع الحقل السابق يتم التعرف على نوع بيانات الحقول التي تم اختيارها للتأكيد على انك كمستخدم تعرف أنواع البيانات في الحقلين . أيضاً يتم التعرف على الحقل ما إذا كان مقتاح أساسي أم لا . عند النقر على زر نوع العلاقة ، فسيتم اظهار نوع العلاقة المنطقية لهذين الحقلين . في الزر انشاء العلاقات سيتم انشاء العلاقة بشكل تلقائي بين الجدولين مع تفعيل تتالي الحذف والإضافة . لإختبار ما اذا كان هناك علاقة بين الجدولين ، من خلال الزر تحقق سيظهر لك نتيجة العلاقة إذا كانت موجودة ونوعها والحقول التي بينها علاقة في الجدولين . عند وجود علاقة سابقة بين الجدولين سيتم تنبيه المستخدم بوجود علاقة سابقة ، هل ترغب باستبدال العلاقة السابقة بعلاقة جديدة ؟؟ وفي حال الموافقة سيتم حذف العلاقة القديمة واستبدالها بالعلاقة الجديدة . طبعاً هنا يجب التنويه أن البرنامج لن يقوم بإنشاء أي علاقة غير صحيحة بين اي حقلين نهائياً . تم اضافة زر لحذف العلاقة بشكل اختياري بين اي جدولين بينهم علاقة . لإجراءاتكم بالتجربة وإفادتي بالنقاط التي قد أكون قد غفلت عنها . TBL Maker.accdb

السلام عليكم ورحمة الله وبركاته.. كنت اعمل على مشروع للقرآن الكريم، يكون ضمن تطبيق قوت القلوب، صورته في التوقيع 🥰 البرنامج من تصميمي وبرمجتي 100% فاحتجت للقرآن الكريم مرتل ومقسم لايات قمت بالعثور على ختمات كاملة وللعديد من القرآء في موقع Archive.org فقمت بتحويل الروابط الى قاعدة بيانات SQLite تتضمن ترتيل القرآن الكريم على شكل ايات كل آية على حدا وبرابط مباشر، أي ستقوم بتشغيل الصوت من الرابط مباشرة بدون تنزيلة طبعا يمكنكم تشغيل الصوت مباشرة من الويب باستخدام الكثير من المكتبات المجانية مثل NAudio.dll وغيرها... قبل كل شيء، هذا الكود لإنشاء الجدول sounds الذي ستكون فيه روابط الصوت لايات القرآن الكريم في قاعدة البيانات.. 1. تسلسل السورة 2. رقم الآية 3. رابط الملف الصوتي للآية 4. معرف القارئ CREATE TABLE "sounds" ( "surah_number" INTEGER, "ayah_number" INTEGER, "audio_url" TEXT, "reader_id" INTEGER ); 0. احمد نعينع 1. الطبلاوي 2. عبد الباسط 3. المنشاوي 4. الحصري السورس كود للفائدة، الذي يقوم بتوليد الايات حسب السور بلغة NET. Sub GenerateQuranAudioLinks(ByVal baseUrl As String, ByVal reader_id As String) ' عدد الآيات لكل سورة من القرآن الكريم Dim surahAyatCounts As Integer() = { 7, 286, 200, 176, 120, 165, 206, 75, 129, 109, 123, 111, 43, 52, 99, 128, 111, 110, 98, 135, 112, 78, 118, 64, 77, 227, 93, 88, 69, 60, 34, 30, 73, 54, 45, 83, 182, 88, 75, 85, 54, 53, 89, 59, 37, 35, 38, 29, 18, 45, 60, 49, 62, 55, 78, 96, 29, 22, 24, 13, 14, 11, 11, 18, 12, 12, 30, 52, 52, 44, 28, 28, 20, 56, 40, 31, 50, 40, 46, 42, 29, 19, 36, 25, 22, 17, 19, 26, 30, 20, 15, 21, 11, 8, 8, 19, 5, 8, 8, 11, 11, 8, 3, 9, 5, 4, 7, 3, 6, 3, 5, 4, 5, 6 } ' حلقة لتوليد جمل SQL لكل سورة وآياتها For surah As Integer = 1 To 114 Dim surahNumber As String = surah.ToString("D3") ' تحويل رقم السورة إلى 3 أرقام Dim ayatCount As Integer = surahAyatCounts(surah - 1) ' توليد جمل SQL بناءً على عدد الآيات لكل سورة For ayah As Integer = 0 To ayatCount Dim ayahNumber As String = ayah.ToString("D3") ' تحويل رقم الآية إلى 3 أرقام Dim fileUrl As String = baseUrl & surahNumber & ".zip" & "/" & surahNumber & ayahNumber & ".mp3" Dim sqlInsert As String = "INSERT INTO sounds (surah_number, ayah_number, audio_url, reader_id) VALUES (" & surah & "," & ayah & "," & "'" & fileUrl & "'" & "," & reader_id & ");" My.Computer.FileSystem.WriteAllText(Application.StartupPath & "\sql_" & reader_id & ".txt", sqlInsert & vbNewLine, True) Next Next '' تشغيل كل عملية في ثريد منفصل باستخدام Task 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb---a7mad--n3ena3---morattal------quran----6236---ayaat-----__verse--by---_189/", "1")) 'احمد نعينع 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb__---mp3------------quran----6236---ayaat-----__verse--by---verse----_-by-/", "2")) 'الطبلاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/192kb----morattal----quran----6236---ayaat-----__verse--by---verse----_-by--ab_525/", "3")) 'عبد الباسط 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/128kb____--mp3-------full-----quran----6236---ayaat-----__verse--by---verse---/", "4")) 'المنشاوي 'Task.Run(Sub() GenerateQuranAudioLinks("https://archive.org/download/64kb___--mp3-----quran----6236---ayaat-----__verse--by---verse----_-by---alhos/", "5")) 'الحصري End Sub ارفقت لكم البيانات على شكل ملفات TXT لكي تعدلو عليها كيفما شئتم. لا تنسوني ووالدي من صالح دعائكم SQLite.zip

السلام عليكم ورحمة الله تعالى وبركاته عندما نتحدث عن توسيط النماذج والتقارير لابد من الأخذ فى الاعتبار ان خاصية PopUp لها تأثير كبير فإن كانت PopUp = True لها أكواد تقوم بعمل التوسيط للنماذج والتقارير داخل الشاشة خاصة ولا تقوم بعملها ان كانت PopUp = False والعكس كذلك واحيانا ننسى ذكر هذا الأمر عند عرض الاكواد والامثلة ولذلك تعمل عند البعض ولا تعمل عند اخرين بل واحيانا اثناء التصميم ننسى هذا الامر ايضا ومن أجل ذلك بعد البحث المرير وترتيب الأفكار بفضل الله تعالى تم دمج الأكواد حتى تعمل تبعا للخاصية PopUp ايما كان اعدادها حتى وان نسى المستخدم ذلك الامر أوحتى إن كان لا يدرى عنه شئ المرفق الاتى ان شاء الله به حل المشكلة تماما طيب ما الفرق بين عمل الاكواد مع خاصية PopUp ان كانت PopUp = True يتم توسيط داخل الشاشة نفسها تبعا لابعاد شاشة العرض نفسها مهما اختلف مقاس الشاشة اما ان كان PopUp = False يتم التوسيط داخل اطار تطبيق الاكس نفسه الاكواد كالاتى اولا كلاس ولابد ان يكون اسم الكلاس clsAutoCenter وان احببتم تغيير الاسم فيجب تعديله فى الاكواد التى تخص الموديول بنفس الاسم الجديد اولا الكلاس : clsAutoCenter '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT 'RECT structure used for API calls. Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI 'POINTAPI structure used for API calls. X As Long Y As Long End Type Private m_hWnd As Long 'Handle of the window. Private m_rctWindow As RECT 'Rectangle describing the sides of the last polled location of the window. Private Const m_ERR_INVALIDHWND = 1 Private Const m_ERR_NOPARENTWINDOW = 2 #If VBA7 Then Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long 'Returns the handle of the parent window of the specified window. #Else Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long 'Returns the handle of the parent window of the specified window. #End If Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String) 'Raises a user-defined error to the calling procedure. Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc End Sub Private Sub UpdateWindowRect() 'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow. Dim ptCorner As POINTAPI If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates. If Not Me.Parent Is Nothing Then 'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Left .Y = m_rctWindow.Top End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Left = ptCorner.X .Top = ptCorner.Y End With 'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Right .Y = m_rctWindow.Bottom End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Right = ptCorner.X .Bottom = ptCorner.Y End With End If Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Sub Public Property Get hWnd() As Long 'Returns the value the user has specified for the window's handle. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then hWnd = m_hWnd Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let hWnd(ByVal lngNewValue As Long) 'Sets the window to use by specifying its handle. 'Only accepts valid window handles. If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then m_hWnd = lngNewValue Else RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle." End If End Property Public Property Get Left() As Long 'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Left = m_rctWindow.Left Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Left(ByVal lngNewValue As Long) 'Moves the window such that its left edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Top() As Long 'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Top = m_rctWindow.Top Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Top(ByVal lngNewValue As Long) 'Moves the window such that its top edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Width() As Long 'Returns the current width (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Width = .Right - .Left End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Width(ByVal lngNewValue As Long) 'Changes the width of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Height() As Long 'Returns the current height (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Height = .Bottom - .Top End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Height(ByVal lngNewValue As Long) 'Changes the height of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Get Parent() As clsAutoCenter 'Returns the parent window as a clFormWindow object. 'For forms, this should be the Access MDI window. Dim fwParent As New clsAutoCenter Dim lngHWnd As Long If m_hWnd = 0 Then Set Parent = Nothing ElseIf apiIsWindow(m_hWnd) Then lngHWnd = apiGetParent(m_hWnd) fwParent.hWnd = lngHWnd Set Parent = fwParent Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If Set fwParent = Nothing End Property ثانيا الموديول ولن يفرق اسم الموديول فى شئ '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT X1 As Long Y1 As Long X2 As Long Y2 As Long End Type #If VBA7 Then Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long #Else Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long #End If Private Const WU_LOGPIXELSX = 88 Private Const WU_LOGPIXELSY = 90 ' Call CenterForm(Me) ' Call CenterReport(Me) Sub CenterForm(F As Form) If F.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = F.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf F.PopUp = True Then Dim formWidth As Long, formHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 formAllMarginsHeight = F.WindowHeight - F.Section(acDetail).Height formAllMarginsWidth = F.Width formWidth = formAllMarginsWidth formHeight = formAllMarginsHeight If formHeight < F.WindowHeight Then formHeight = F.WindowHeight End If DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight End If End Sub Sub CenterReport(R As Report) If R.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = R.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf R.PopUp = True Then Dim ReportWidth As Long, ReportHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height ReportAllMarginsWidth = R.Width ReportWidth = ReportAllMarginsWidth ReportHeight = ReportAllMarginsHeight If ReportHeight < R.WindowHeight Then ReportHeight = R.WindowHeight End If DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight End If End Sub Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch End Function Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch End Function Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long) Dim R As RECT Dim RetVal As Long #If VBA7 Then Dim hWnd As LongPtr #Else Dim hWnd As Long #End If hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) Width = R.X2 - R.X1 Height = R.Y2 - R.Y1 End Sub ويتم استدعاء كود توسيط النماذج من خلال السطر الاتى فى حدث عند الفتح Call CenterForm(Me) ويتم استدعاء كود توسيط التقارير من خلال السطر الاتى فى حدث عند الفتح Call CenterReport(Me) فى حالة كانت PopUp = True يتم توسيط النماذج والتقارير فى وسط شاشة الحاسب الالى تمام تبعا لابعاد الشاشة اما فى حالة PopUp = False يتم توسيط النماذج والتقارير فى داخل اطار برنامج الاكسس نفسه والان اليكم المرفق بالمثال العملى AutoCentre.mdb

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

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

هذا الملف قالب جاهز لنموذج صفحة دخول وتغيير بيانات المستخدم والتحكم بالمستخدمين 🙂 كلمة المرور لجميع المستخدمين : 123 للتحميل : 🙂 قالب جاهز لنموذج تسجيل الدخول وتغيير كلمة المرور.accdb

وعليكم السلام -يمكنك استخدام هذه المعادلة =IFERROR(INDEX(ورقة1!B2:B270,MATCH(0,COUNTIF($A$1:A1,ورقة1!B2:B270),0)),"") تلخيص1.xlsx

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكن بطريقة ونكهة مختلفتين ▫▪◽◾◻◼. "أداة مستورد السجلات الذكي من Excel" ، أداة مبتكرة تتيح لك استيراد البيانات من ملفات Excel إلى قواعد بيانات Access بكل مرونة وسرعة . يتميز هذا البرنامج أو الأداة بواجهة بسيطة وميزات قوية تجعل التعامل مع البيانات تجربة مريحة ، حتى للمستخدمين الذين ليست لديهم خبرة تقنية كبيرة في التعامل مع هذا النوع من المتطلبات . فالكثير من الأشخاص في منتدانا هنا سأل عن إمكانية استيراد بيانات من اكسل من حقل محدد أو بطرق محددة ( تناسب إحتياجاته ) ، ولهذا كانت الفكرة هذه تنفيذاً لمتطلباتهم .. 🎯 سنستعرض أهم ميزات هذا البرنامج وكيف يمكن أن يسهم في تحسين إنتاجيتك وتوفير وقتك . تابع القراءة لاكتشاف كيف يمكنك الاستفادة من هذا الحل الذكي لإدارة البيانات 😇 . ميزات برنامج مستورد السجلات الذكي من Excel 📂 التكامل مع Excel يمكن اختيار ملفات Excel بسهولة باستخدام نافذة اختيار الملفات . يدعم البرنامج ملفات بصيغة xls / xlsx . 📋 التعامل مع الأوراق والبيانات عرض جميع أوراق العمل (Sheets) الموجودة في ملف Excel المحدد . عرض أسماء الأعمدة في الورقة المحددة لتسهيل تحديد العمود المستهدف . 🚀 الاستيراد المرن للبيانات استيراد بيانات من عمود محدد في ملف Excel بناءً على اختيار المستخدم . تحديد الصفوف التي تبدأ منها عملية الاستيراد (لتجاوز رؤوس الأعمدة إن وجدت 👌 ) . 🗂️ الإدارة المتقدمة للبيانات داخل Access استيراد البيانات إلى جدول محدد داخل قاعدة البيانات الحالية . دعم لتحديد الحقول الهدف داخل الجدول . إمكانية تفعيل خاصية الترقيم التلقائي لإضافة قيم تسلسلية إلى الحقول المخصصة ( باستخدام الدالة DMAX ). ⚡ أداء عالي مع دفعات من البيانات تقسيم البيانات إلى دفعات عند استيراد كميات كبيرة لتجنب مشاكل الأداء . إدارة مرنة لعدد السجلات التي يتم استيرادها في كل دفعة . 🎨 واجهة مستخدم ديناميكية إظهار أو إخفاء المساعدة البصرية بضغطة زر . تحديث الكومبوبوكس بطريقة ديناميكيًا بناءً على اختيارات المستخدم . 🔒 إجراءات أمان واسترجاع دعم لاسترجاع البيانات عند حدوث خطأ أثناء عملية الاستيراد ( Rollback ) . التنبيه برسائل خطأ واضحة إذا لم يتم اختيار الملف أو إعداد الخيارات بشكل صحيح . 🧹 إدارة الموارد تنظيف جميع الموارد المفتوحة (ملفات Excel أو الاتصال بالبيانات) عند إغلاق النموذج . منع أي تأثير سلبي على النظام عند حدوث خطأ . ✨ سهولة الاستخدام تصميم بسيط يعرض التعليمات ويطلب إدخال البيانات الضرورية فقط . رسائل توجيهية للمستخدم لتحسين تجربة الاستخدام . ⚙️ المرونة في تخصيص الخيارات خيارات لتحديث السجلات الموجودة أو إضافة سجلات جديدة . دعم مجموعات البيانات المختلفة من خلال تحديد طريقة المعالجة . صورة واجهة الأداة .. الملف المرفق مفتوح المصدر .. 💢 Excel Importor.accdb 💢 **************************** ما الجديد في هذا للتحديث ؟ 📊 واجهة المستخدم (UI) : واجهة مستخدم تحتوي على أزرار وخيارات لتسهيل عملية استيراد البيانات من إكسل إلى أكسيس . 📂 يمكن للمستخدم اختيار ملف إكسل من خلال مربع حوار اختيار الملفات . يتم تحميل بيانات الملف المحدد وعرض أسماء الأوراق (Sheets) والأعمدة (Columns) في القوائم المنسدلة . 📥 يدعم الكود طريقتين لاستيراد البيانات : 🔢 استيراد عمود واحد ( الإصدار الأول ): حيث يتم استيراد بيانات عمود معين من إكسل إلى حقل محدد في جدول أكسيس. 🔢🔢 استيراد عدة أعمدة ( بناءً على طلب الأخوة ): حيث يتم استيراد بيانات عدة أعمدة من إكسل إلى عدة حقول في جدول أكسيس. 💥 يتم التحقق من صحة البيانات المحددة قبل بدء عملية الاستيراد . 🔢 إدارة الترقيم التلقائي : يدعم البرنامج إمكانية الترقيم التلقائي للحقول المحددة أثناء عملية الاستيراد . يمكن للمستخدم تفعيل أو تعطيل هذه الميزة وتحديد الحقل الذي سيتم الترقيم التلقائي عليه . ⚠️ إدارة الأخطاء : يتم التعامل مع الأخطاء المحتملة أثناء عملية الاستيراد ( مثل عدم وجود ملف إكسل محدد أو عدم تطابق الأعمدة ... إلخ ) . الملف المرفق مفتوح المصدر .. 💢 Excel Importor 2025.accdb1.07 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 20 downloads 💢 🔴 وجب علي التنويه إلى نقطة مهمة وهي :- قد يأتي أحد الأخوة لاختيار ملف يحتوي على ترويسة أو صورة في أول ملف الإكسل الذي اختاره ، ويقول لي أنه لم يظهر لي أي أسماء للأعمدة التي تحدثت عنها ( وأن الأداة لم تخدمه بشكل أو بآخر ) وهنا وأعتذر منه مسبقاً بأن هذا الخلل ليس في الأداة وإنما في ملف الآكسل . فأنا لا استطيع أن أجبرك على تصميم معين لملف الآكسل الذيتريد الإستيراد منه ، ولكني بنفس الوقت أقترح عليك أن تزيل هذه الإضافات والمعوقات كي تستفيد من الأداة بشكل ممتاز . ⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟 في التحديث الجديد ، تم الإعتماد على الفكرة المطروحه هنا في هذا الموضوع " رافع ملفات جوجل درايف 2025 " ، لكن مع اختلاف بسيط جزئي كما أخبارناكم سابقاً .. تم إضافة الفكرة بعد استكمالها ، وبناءً على طلب الأساتذة لتكتمل الفكرة من جميع الجوانب ( ملف اكسيل محل ، أو مرفوق على جوجل شيت أو ملف اكسيل مرفوع برابط مباشر في جوجل درايف - يتم تحويله الى جوجل شيت . فقط اختر الرابط ( نسخ ولصق ) وادخاله في رسالة رابط الملف كما في الصورة التالية :- الأداة بتحديثها الجديد تدعم استكمال الجلسة لآخر رابط تم استخدامه ( توفيراً للوقت واختصاراً لفكرة استخدام الرابط نفسه في كل مرة ) ، بحيث تظهر لك رسالة كالآتي :- بحيث اذا كان اختيارك لـ Yes يتم التعرف على آخر رابط تم استخدامه ( حتى بعد اغلاق الأداة ) ، وإذا كان رد المستخدم No يتم اظهار رسالة ادخال رابط جديد ( ويتم اعتماده للجلسة اللاحقة ) .. الأداة تحتوي على معالج مساعد لمساعدة المستخدم ( أول مرة فقط ) على انشاء حساب في جوجل درايف وكيفية التعامل مع الـ API الخاصة بـ Google Sheets لتهيئة الأداة للتعامل مع روابط جوجل شيت لاستيراد السجلات منه . في التحديث الجديد للأداة ، يتم التعرف على الأخطاء التي يمكن حصولها أثناء اختيار حقل وخلية لا يوجد بينهما توافق في نوع البيانات ، فمثلاً لو تم اختيار خليه تحتوي على تاريخ ويقابلها حقل في الجدول ( في آكسيس ) من نوع رقمي مثلاً ، فإن الاداة تخبرك بنوع الحقل والتصحيح الذي يمكن تعديله .. الفكرة الحالية نفسها كما هو التعامل مع ملف محلي ( ملف اكسيل داخل الكمبيوتر ) لا تختلف في التعامل وطريقة الإستخدام كلياً .. واجهة الأداة :- * صورة من الواجهة الخاصة بـ Google Sheets . يلزم إضافة مكتبة Microsoft Office xx.0 Object Library فقط .. ⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟 إصلاح مشكلة الإستيراد لأكثر من سجل من جوجل شيت . في الإصدار الأخير السابق وأتوجه بالشكر للأستاذ @Moosak للفته انتباهي لهذا الخلل . فقد تم بحمد الله تلافي وحل المشكلة من جذورها وإضافة ميزة جديدة وهي التعرف على طول القيمة التي سيتم استيرادها ( للحقول النصية ) . حيث طول الحقل النصي في اكسيس 255 حرف . وبهذا لا يمكن استيراد كامل القيمة اذا كانت أكبر من 255 حرف ، وسيتم ترك الفكرة للمستخدم بأن يكمل الإستيراد بعد ان يتم تقليص قيمة الخليه من جوجل شيت الى 255 أو الغاء العملية بالكامل .. وعليه ، فإن التعديل الجديد حل هذه المشكلة وغيرها .. ⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟⭐🌟 ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ ------------------------------ Excel Importor 2.0.zip757.56 kB · 1 download ------------------------------ ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ

وعليكم السلام ورحمة الله تعالى وبركاته تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v3 .xlsb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم دالة لتفقيط التواريخ أو الفرق بين تاريخين بعدة أساليب وأنماط . حيث تهدف إلى حساب الفارق الزمني بين تاريخين وتقديم النتيجة بشكل نصي وبالعربية . هذا الكود يتضمن العديد من المزايا التي تسمح بإخراج النتيجة بأشكال متعددة حسب رغبة المستخدم. 💥 الفكرة العامة للدالة الدالة الأساسية التي تم إنشاؤها هي DurationToFullWords ، وهي تقوم بحساب الفارق بين تاريخين معينين (StartDate و EndDate) وتنسيق النتيجة بشكل نصي باستخدام الوحدات الزمنية مثل "سنة" ، "شهر" ، و "يوم" . كما تدعم العديد من الخيارات لتخصيص المخرجات مثل تحديد تنسيق النتيجة وإظهار الأرقام مع الكلمات العربية . 1️⃣ الجزء الأول تعريف المعاملات والتأكد من صحة البيانات المدخلة :- وقد تم تعديل الفكرة بحيث يستقبل الكود التاريخين الأصغر أولاً ثم الأكبر بغض النظر عن ما اذا كان مربع النص الأول يضم تاريخ أكبر أم أصغر .. If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If حيث StartDate و EndDate هما التاريخان اللذان يتم مقارنة الفارق بينهما . أولاً يتم التأكد من أن كلا التاريخين مدخلين بشكل صحيح (غير فارغين) . ثم يقارن اي القيمتين أسغر لجعلها بداية والأكبر نهاية 😁 . 2️⃣ الجزء الثاني حساب الفارق بين التواريخ :- y = DateDiff("yyyy", tempDate, EndDate) m = DateDiff("m", tempDate, EndDate) d = DateDiff("d", tempDate, EndDate) totalDays = DateDiff("d", StartDate, EndDate) حيث DateDiff هي دالة تستخدم لحساب الفرق بين التواريخ بوحدات مختلفة مثل السنوات (yyyy) ، الأشهر (m) ، و الأيام (d) . فيتم حساب الفرق بالسنوات أولاً ، ثم الأشهر ، وأخيراً الأيام . ثم يتم جمع totalDays لحساب الفارق الإجمالي بالأيام بين التاريخين . 3️⃣ الجزء الثالث المعالجة الخاصة للأشهر والأيام :- If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If حيث RoundResults هو خيار اختياري لتقريب النتائج . فإذا كان هذا الخيار مفعلًا ، يتم تعديل الأشهر أو الأيام ليتم تقريبها بشكل منطقي . فإذا كانت الأشهر 11 شهراً والأيام 25 أو أكثر ، يتم زيادة السنة بمقدار واحد . وإذا كانت الأشهر 5 والأيام 25 أو أكثر ، يتم تحويل الأشهر إلى 6 . 4️⃣ الجزء الرابع تنسيق النتائج حسب الخيارات :- Select Case FormatOption Case "Y" ' تنسيق الفرق بالسنوات فقط Case "M" ' تنسيق الفرق بالأشهر فقط Case "D" ' تنسيق الفرق بالأيام فقط Case "M/D" ' تنسيق الفرق بالأشهر والأيام Case "Y/M" ' تنسيق الفرق بالسنوات والأشهر Case Else ' تنسيق كامل (سنوات، أشهر، أيام) End Select التوضيح على شكل نقاط :- تعتمد الدالة على FormatOption لتحديد التنسيق الذي يجب أن تظهر به النتيجة ، كالتالي :- Y : يعرض النتيجة بالسنوات فقط . M : يعرض النتيجة بالأشهر فقط . D : يعرض النتيجة بالأيام فقط . M/D : يعرض النتيجة بالأشهر والأيام . Y/M : يعرض النتيجة بالسنوات والأشهر . القيمة الافتراضية : يعرض النتيجة كاملة (سنوات ، أشهر ، أيام) . 5️⃣ الجزء الخامس الدوال المساعدة :- Function SimpleUnit(Number As Long, UnitName As String) As String وتقوم هذه الدالة بـ :- بتنسيق الأرقام مع الوحدات الزمنية مثل "سنة" ، "شهر" ، أو "يوم" . تتعامل مع العدد بصيغة الجمع أو المفرد حسب الرقم المدخل . على سبيل المثال ، إذا كان العدد 1 ، يتم إرجاع "1 سنة" أو "1 شهر"، وإذا كان العدد 2 يتم إرجاع "سنتين" أو "شهرين" ... إلخ . Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String وتقوم هذه الدالة بتنسيق الأرقام مع الوحدات بشكل معين . على سبيل المثال :- OnlyNumbers : إذا كان True ، تعرض الأرقام فقط . ShowNumberWithWord : إذا كان True ، تعرض الرقم مع الكلمة باللغة العربية في قوسين مثل : "5 (خمسة) سنوات" . Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية . كما أنها تدعم الكلمة بصيغة المذكر أو المؤنث حسب القيمة المدخلة في IsFeminine . Function NumberWithUnitArabic(Number As Long, UnitName As String) As String وتقوم هذه الدالة بتحويل الرقم إلى كلمة باللغة العربية مع الوحدة المناسبة (مثل "سنة واحدة" ، "شهران" ، "أيام") . 6️⃣ الجزء السادس التعامل مع الحروف العطف (مثل "و" ) .في الجزء :- If Right(result, 3) = " و " Then result = Left(result, Len(result) - 3) End If فبعد تنسيق النتيجة ، يتم إزالة الفاصلة الزائدة "و" في النهاية إذا كانت موجودة . 7️⃣ الجزء السابع : النتيجة النهائية :- If result = "" Then result = "أقل من يوم" DurationToFullWords = result في حال كانت النتيجة فارغة ( قيمة بفارق 0 ) ، يتم تعيين النتيجة إلى "أقل من يوم" . 💢 تم إضافة دالة تقوم بتفقيط التاريخ بأكثر من شكل ( 3 تنسيقات ) ، على سبيل المثال ، تاريخ اليوم هو 08/04/2025 والنتيجة له :- الثامن من شهر نيسان لعام ألفين وخمسة وعشرين م الثامن من شهر أبريل لعام ألفين وخمسة وعشرين م والجزء الجديد هو قراءة التاريخ بالأشهر الهجرية :- الثامن من شهر ربيع ثان لعام ألفين وخمسة وعشرين هـ 📛 الآن الكود العام في مديول منفرد :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit Function DurationToFullWords(StartDate As Variant, EndDate As Variant, _ Optional FormatOption As String = "", _ Optional ShortFormat As Boolean = False, _ Optional OnlyNumbers As Boolean = False, _ Optional ShowNumberWithWord As Boolean = False, _ Optional RoundResults As Boolean = False) As String If FormatOption = "" Then FormatOption = "FullWords" Dim y As Long, m As Long, d As Long Dim tempDate As Date Dim Result As String Dim totalMonths As Long Dim totalDays As Long Dim weeks As Long If IsNull(StartDate) Or IsNull(EndDate) Then DurationToFullWords = "لم يتم إدخال تاريخين للمقارنة" Exit Function End If If EndDate < StartDate Then tempDate = StartDate StartDate = EndDate EndDate = tempDate End If tempDate = StartDate totalDays = DateDiff("d", StartDate, EndDate) y = DateDiff("yyyy", tempDate, EndDate) If DateAdd("yyyy", y, tempDate) > EndDate Then y = y - 1 tempDate = DateAdd("yyyy", y, tempDate) m = DateDiff("m", tempDate, EndDate) If DateAdd("m", m, tempDate) > EndDate Then m = m - 1 tempDate = DateAdd("m", m, tempDate) d = DateDiff("d", tempDate, EndDate) totalMonths = (y * 12) + m weeks = totalDays \ 7 If ShortFormat Then If y > 0 Then Result = Result & SimpleUnit(y, "سنة") & " و " If m > 0 Then Result = Result & SimpleUnit(m, "شهر") & " و " If d > 0 Then Result = Result & SimpleUnit(d, "يوم") & " و " Else If RoundResults Then If m = 11 And d >= 25 Then y = y + 1 m = 0 d = 0 ElseIf m = 5 And d >= 25 Then m = 6 d = 0 End If End If Select Case FormatOption Case "Y" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) Else If m < 6 Then Result = "أقل من نصف سنة" ElseIf m = 6 And d = 0 Then Result = "نصف سنة" ElseIf m = 6 And d > 0 Then Result = "أكثر من نصف سنة" ElseIf m > 6 Then Result = "أكثر من نصف سنة" End If End If Case "M" If totalMonths > 0 Then Result = FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) ElseIf d > 0 Then If d = 30 Or d = 31 Then Result = "شهر" ElseIf d < 30 Then Result = "أقل من شهر" End If Else Result = "أقل من شهر" End If Case "D" Result = FormatNumberWithWord(totalDays, "يوم", OnlyNumbers, ShowNumberWithWord) Case "M/D" If totalMonths > 0 Then Result = Result & FormatNumberWithWord(totalMonths, "شهر", OnlyNumbers, ShowNumberWithWord) If d > 0 Then Result = Result & " و " End If If d > 0 Then If d >= 7 And totalMonths = 0 Then Select Case weeks Case 1 Result = Result & "أسبوع" Case 2 Result = Result & "أسبوعان" Case 3 To 4 Result = Result & FormatNumberWithWord(weeks, "أسبوع", OnlyNumbers, ShowNumberWithWord) Case Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select Else Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End If End If Case "Y/M" If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) Case Else If y > 0 Then Result = Result & FormatNumberWithWord(y, "سنة", OnlyNumbers, ShowNumberWithWord) & " و " If m > 0 Then Result = Result & FormatNumberWithWord(m, "شهر", OnlyNumbers, ShowNumberWithWord) & " و " If d > 0 Then Result = Result & FormatNumberWithWord(d, "يوم", OnlyNumbers, ShowNumberWithWord) End Select End If If Right(Result, 3) = " و " Then Result = Left(Result, Len(Result) - 3) End If If Result = "" Then Result = "أقل من يوم" DurationToFullWords = Result End Function Function SimpleUnit(Number As Long, UnitName As String) As String Select Case Number Case 1 SimpleUnit = "1 " & UnitName Case 2 If UnitName = "سنة" Then SimpleUnit = "2 سنتين" ElseIf UnitName = "يوم" Then SimpleUnit = "2 يومين" Else SimpleUnit = "2 " & UnitName & "ين" End If Case 3 To 10 If UnitName = "سنة" Then SimpleUnit = Number & " سنوات" ElseIf UnitName = "شهر" Then SimpleUnit = Number & " أشهر" ElseIf UnitName = "يوم" Then SimpleUnit = Number & " أيام" Else SimpleUnit = Number & " " & UnitName End If Case Else SimpleUnit = Number & " " & UnitName End Select End Function Function FormatNumberWithWord(Number As Long, UnitName As String, OnlyNumbers As Boolean, ShowNumberWithWord As Boolean) As String If OnlyNumbers Then FormatNumberWithWord = SimpleUnit(Number, UnitName) ElseIf ShowNumberWithWord Then FormatNumberWithWord = Number & " (" & NumberToArabicUnit(Number, UnitName) & ")" Else FormatNumberWithWord = NumberToArabicUnit(Number, UnitName) End If End Function Function NumberToArabicWords(ByVal Number As Long, Optional IsFeminine As Boolean = False) As String Dim UnitsMasc, UnitsFem, Tens, TeensMasc, TeensFem, Hundreds UnitsMasc = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") UnitsFem = Array("", "واحدة", "اثنتان", "ثلاث", "أربع", "خمس", "ست", "سبع", "ثمان", "تسع") TeensMasc = Array("عشرة", "أحد عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") TeensFem = Array("عشر", "إحدى عشرة", "اثنتا عشرة", "ثلاث عشرة", "أربع عشرة", "خمس عشرة", "ست عشرة", "سبع عشرة", "ثماني عشرة", "تسع عشرة") Tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") Hundreds = Array("", "مئة", "مئتان", "ثلاثمئة", "أربعمئة", "خمسمئة", "ستمئة", "سبعمئة", "ثمانمئة", "تسعمئة") Dim Words As String Dim n As Long Dim h, t, u As Integer If Number = 0 Then NumberToArabicWords = "صفر" Exit Function End If If Number = 10 Then NumberToArabicWords = IIf(IsFeminine, "عشر", "عشرة") Exit Function End If If Number > 999 Then Dim Thousands As Long Thousands = Number \ 1000 Words = NumberToArabicWords(Thousands, False) & " ألف" n = Number Mod 1000 If n > 0 Then Words = Words & " و " & NumberToArabicWords(n, IsFeminine) NumberToArabicWords = Words Exit Function End If h = Number \ 100 t = (Number Mod 100) \ 10 u = Number Mod 10 If h > 0 Then Words = Hundreds(h) If (Number Mod 100) >= 11 And (Number Mod 100) <= 19 Then If Words <> "" Then Words = Words & " و " If IsFeminine Then Words = Words & TeensFem((Number Mod 100) - 10) Else Words = Words & TeensMasc((Number Mod 100) - 10) End If Else Dim UnitsArray UnitsArray = IIf(IsFeminine, UnitsFem, UnitsMasc) If t > 1 Then If u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) & " و " & Tens(t) Else If Words <> "" Then Words = Words & " و " Words = Words & Tens(t) End If ElseIf u > 0 Then If Words <> "" Then Words = Words & " و " Words = Words & UnitsArray(u) End If End If NumberToArabicWords = Words End Function Function NumberWithUnitArabic(Number As Long, UnitName As String) As String Dim Result As String Select Case UnitName Case "سنة" Select Case Number Case 1: Result = "سنة واحدة" Case 2: Result = "سنتان" Case 3 To 10: Result = Number & " سنوات" Case Else: Result = Number & " سنة" End Select Case "شهر" Select Case Number Case 1: Result = "شهر واحد" Case 2: Result = "شهران" Case 3 To 10: Result = Number & " أشهر" Case Else: Result = Number & " شهر" End Select Case "يوم" Select Case Number Case 1: Result = "يوم واحد" Case 2: Result = "يومان" Case 3 To 10: Result = Number & " أيام" Case Else: Result = Number & " يوم" End Select Case Else Result = Number & " " & UnitName End Select NumberWithUnitArabic = Result End Function Function NumberToArabicUnit(Number As Long, UnitName As String) As String Dim word As String Dim feminine As Boolean Select Case UnitName Case "سنة": feminine = True Case "شهر": feminine = False Case "يوم": feminine = False End Select Select Case Number Case 1 word = UnitName & " " & IIf(feminine, "واحدة", "واحد") Case 2 If feminine Then word = "سنتان" Else If UnitName = "يوم" Then word = "يومان" Else word = UnitName & "ان" End If End If Case 3 To 10 word = NumberToArabicWords(Number, feminine) If UnitName = "يوم" Then word = word & " أيام" ElseIf UnitName = "سنة" Then word = word & " سنوات" ElseIf UnitName = "شهر" Then word = word & " أشهر" End If Case Else word = NumberToArabicWords(Number, feminine) & " " & UnitName End Select NumberToArabicUnit = word End Function Function ConvertDateToText(ByVal DateValue As Date, _ Optional ByVal CalendarType As String = "Gregorian", _ Optional ByVal MonthNameStyle As String = "Standard") As String Dim dayNumber As Integer Dim monthNumber As Integer Dim yearNumber As Integer Dim dayText As String Dim monthText As String Dim yearText As String If LCase(CalendarType) = "hijri" Then dayNumber = Val(Format$(DateValue, "dd", vbCalHijri)) monthNumber = Val(Format$(DateValue, "mm", vbCalHijri)) yearNumber = Val(Format$(DateValue, "yyyy", vbCalHijri)) Else dayNumber = day(DateValue) monthNumber = month(DateValue) yearNumber = year(DateValue) End If Select Case dayNumber Case 1: dayText = "الأول" Case 2: dayText = "الثاني" Case 3: dayText = "الثالث" Case 4: dayText = "الرابع" Case 5: dayText = "الخامس" Case 6: dayText = "السادس" Case 7: dayText = "السابع" Case 8: dayText = "الثامن" Case 9: dayText = "التاسع" Case 10: dayText = "العاشر" Case 11: dayText = "الحادي عشر" Case 12: dayText = "الثاني عشر" Case 13: dayText = "الثالث عشر" Case 14: dayText = "الرابع عشر" Case 15: dayText = "الخامس عشر" Case 16: dayText = "السادس عشر" Case 17: dayText = "السابع عشر" Case 18: dayText = "الثامن عشر" Case 19: dayText = "التاسع عشر" Case 20: dayText = "العشرين" Case 21: dayText = "الحادي والعشرين" Case 22: dayText = "الثاني والعشرين" Case 23: dayText = "الثالث والعشرين" Case 24: dayText = "الرابع والعشرين" Case 25: dayText = "الخامس والعشرين" Case 26: dayText = "السادس والعشرين" Case 27: dayText = "السابع والعشرين" Case 28: dayText = "الثامن والعشرين" Case 29: dayText = "التاسع والعشرين" Case 30: dayText = "الثلاثين" Case 31: dayText = "الحادي والثلاثين" Case Else: dayText = CStr(dayNumber) End Select If LCase(CalendarType) = "hijri" Then monthText = Choose(monthNumber, _ "محرم", "صفر", "ربيع أول", "ربيع ثان", "جمادى أول", "جمادى ثان", _ "رجب", "شعبان", "رمضان", "شوال", "ذو القعدة", "ذو الحجة") ElseIf LCase(MonthNameStyle) = "syriac" Then monthText = Choose(monthNumber, _ "كانون الثاني", "شباط", "آذار", "نيسان", "أيار", "حزيران", _ "تموز", "آب", "أيلول", "تشرين الأول", "تشرين الثاني", "كانون الأول") Else monthText = Choose(monthNumber, _ "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") End If yearText = NumberToArabicText(yearNumber) Dim eraSuffix As String If LCase(CalendarType) = "hijri" Then eraSuffix = " هـ" Else eraSuffix = " م" End If ConvertDateToText = dayText & " من شهر " & monthText & " لعام " & yearText & eraSuffix End Function Function NumberToArabicText(ByVal TheNumber As Long) As String Dim MyArray1(0 To 9) As String Dim MyArray2(0 To 9) As String Dim MyArray3(0 To 9) As String Dim Result As String Dim Hundreds As String Dim Tens As String Dim Ones As String Dim AndConnector As String AndConnector = " و" MyArray1(0) = "" MyArray1(1) = "مائة" MyArray1(2) = "مائتين" MyArray1(3) = "ثلاثمائة" MyArray1(4) = "أربعمائة" MyArray1(5) = "خمسمائة" MyArray1(6) = "ستمائة" MyArray1(7) = "سبعمائة" MyArray1(8) = "ثمانمائة" MyArray1(9) = "تسعمائة" MyArray2(0) = "" MyArray2(1) = " عشر" MyArray2(2) = "عشرين" MyArray2(3) = "ثلاثين" MyArray2(4) = "أربعين" MyArray2(5) = "خمسين" MyArray2(6) = "ستين" MyArray2(7) = "سبعين" MyArray2(8) = "ثمانين" MyArray2(9) = "تسعين" MyArray3(0) = "" MyArray3(1) = "واحد" MyArray3(2) = "اثنين" MyArray3(3) = "ثلاثة" MyArray3(4) = "أربعة" MyArray3(5) = "خمسة" MyArray3(6) = "ستة" MyArray3(7) = "سبعة" MyArray3(8) = "ثمانية" MyArray3(9) = "تسعة" If TheNumber = 0 Then NumberToArabicText = "صفر" Exit Function End If Dim HundredsDigit As Integer Dim TensDigit As Integer Dim OnesDigit As Integer HundredsDigit = (TheNumber Mod 1000) \ 100 TensDigit = (TheNumber Mod 100) \ 10 OnesDigit = TheNumber Mod 10 If HundredsDigit >= 0 And HundredsDigit <= 9 Then Hundreds = MyArray1(HundredsDigit) Else Hundreds = "" End If If TensDigit = 1 Then Select Case OnesDigit Case 0: Tens = "عشرة" Case 1: Tens = "إحدى عشرة" Case 2: Tens = "إثنتا عشرة" Case Else: Tens = MyArray3(OnesDigit) & MyArray2(TensDigit) End Select Else Ones = MyArray3(OnesDigit) Tens = MyArray2(TensDigit) If Ones <> "" And Tens <> "" Then Tens = Ones & AndConnector & Tens Else Tens = Ones & Tens End If End If If Hundreds <> "" And Tens <> "" Then Result = Hundreds & AndConnector & Tens Else Result = Hundreds & Tens End If If TheNumber > 999 Then Dim Thousands As Long Dim Remainder As Long Thousands = TheNumber \ 1000 Remainder = TheNumber Mod 1000 Dim ThousandsText As String ThousandsText = NumberToArabicText(Thousands) If Thousands = 1 Then ThousandsText = "ألف" ElseIf Thousands = 2 Then ThousandsText = "ألفين" ElseIf Thousands >= 3 And Thousands <= 10 Then ThousandsText = NumberToArabicText(Thousands) & " آلاف" Else ThousandsText = NumberToArabicText(Thousands) & " ألف" End If If Remainder > 0 Then Result = ThousandsText & AndConnector & NumberToArabicText(Remainder) Else Result = ThousandsText End If End If NumberToArabicText = Result End Function ولتسهيل فهم الموضوع عند الإستدعاءات المختلفة ، تم انشاء نموذج بسيط يضم 22 زر ولكل زر طريقة استدعاء مختلفة تسهيلاً للمستخدم كي تتوضح له آلية العمل . كما تم اضافة 3 مربعات نص كل منها يعرض التفقيط بشكل مختلف . ♻ المرفق :- Date Duration to Arabic Words.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 اليوم سأقدم لكم فكرة لإنشاء ساعة رقمية مشابهة لألواح الإعلانات المضيئة ، ولكن بطريقة و نكهة مختلفتين كالعادة ▫▪◽◾◻◼ . صورة للنتيجة .. المرفق مفتوح المصدر دون إطالة BackLight2.accdb

وعليكم السلام ورحمة الله نعالى وبركاته دالة IFS هي دالة موجودة في إصدارات Excel الحديثة ولكنها غير مدعومة في Excel 2019 يمكنك استخدام دوال أخرى مثل IF المتداخلة لتحقيق نفس الوظيفة على سبيل المثال =IF(A2="","",IF(A2<5,"ضعيف",IF(A2<10,"متوسط",IF(A2<15,"حسن","ممتاز")))) أو =IF(A2="","",CHOOSE(MATCH(A2,{0,5,10,15},1),"ضعيف","متوسط","حسن","ممتاز")) يمكنك تعديل هذه الصيغ لتشمل العديد من الشروط المتداخلة حسب حاجتك إذا كنت ترغب في محاكاة دالة IFS باستخدام VBA يمكننا كتابة دالة مخصصة تقوم بالتحقق من عدة شروط في تسلسل مشابه لدالة IFS في Module قم بلصق الكود التالي Function IFS_Formula(ParamArray tmp() As Variant) As Variant Dim i As Integer For i = LBound(tmp) To UBound(tmp) Step 2 If tmp(i) Then IFS_Formula = tmp(i + 1) Exit Function End If Next i IFS_Formula = CVErr(xlErrValue) End Function واستخدام الدالة التالية =IFS_Formula(A2="","",A2<5,"ضعيف",A2<10,"متوسط",A2<15,"حسن",A2>=15,"ممتاز") في حالة لديك حاجة مستمرة لاستخدام دالة IFS فإن الحل الأكثر فعالية سيكون الترقية إلى Excel 2021 رابط التحميل https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file حيث تكون هذه الدالة مدعومة بشكل كامل بالتوفيق............. TEST-IFS.xlsb

السلام عليكم 🙂 رجاء الرجوع الى النسخة الاولى من هذا الموضوع لفهم تفاصيل الكود . عرضت عليكم جميع التفاصيل في عمل حدث الـ Data Macro ، فكان على المبرمج ان يكتب جميع خطوات الكود لكل حقل ولكل حدث ، يدويا !! وهنا اعطيكم طريقة طريقة عمله برمجيا (يعني المبرمج ما عنده عذر من الان ان لا يستخدم هذه الاداة في برامجه 🙂 ). هذه واجهة وكائنات البرنامج: . 9. نقوم بالنقر على الزر رقم 9 مرة واحدة فقط ، فيقوم بنسخ الجدول جدول tbl_x_AuditTrail فارغ ، والوحدة النمطية mod_UserName_PcName ، الى قاعدة البيانات التي تم اختيارها في رقم 3 ، 1. جدول tbl_x_AuditTrail فارغ ، وسيتم عمل نسخة منه ومن الوحدة النمطية mod_UserName_PcName عند النقر على الزر رقم 9 ، الى قاعدة البيانات التي تم اختيارها في رقم 3 ، 2. يجب اختيار قاعدة البيانات التي تريد عمل احداث الجداول عن طريق الـ Data Macro فيها ، وسيتم ظهور اسم قاعدة البيانات في الرقم 3 ، وفي نفس الوقت سيتم ظهور اسماء جداولها في الرقم 4 ، 4. اختار الجدول الذي تريد عمل الاحداث عليه ، ومنها ستظهر اسماء حقوله في الرقم 5 ، 5. تختار اسماء الحقول التي تريد ان تتابع متغيراتها (وهو اساس هذا البرنامج) ، وتستطيع اختيار جميع الحقول لهذا الحدث بالنقر على الزر 6 : 5.1 لتسجيل وحفظ متغير الحقل عند اضافة سجل جديد (الحاق سجل جديد) ، 5.2 لتسجيل وحفظ متغير الحقل عند عمل تغيير على قيمة الحقل (بعد تحديث الحقل) ، 5.3 لتسجيل وحفظ متغير الحقل عند حذف السجل ، 7. يجب اختيار حقل المفتاح الاساسي في الجدول ، 8. عند الانتهاء من الاختيارات ، ننقر على الزر رقم 8 ، فيقوم بعمل الـ Data Macro لجميع الحقول في الجدول الذي تم اختياره ، وستاتيك رسالة تؤكد انتهاء العمل. وللعمل على حقول جدول آخر ، ابدأ من الرقم 4 اعلاه مرة اخرى. هنا سأعطي مثال عن طريقة العمل ، والنتائج: هذه قاعدة البيانات التي ساعمل عليها ، ونرى انه لا يوجد بها الجدول tbl_x_AuditTrail فارغ ، ولا الوحدة النمطية mod_UserName_PcName ، ولا توجد اي احداث في المربع الاحمر : . خطوات العمل: . والنتيجة في قاعدة البيانات الاخرى: . والان لنرى عندما نعمل اي تغيير في المتغيرات: . هنا نرى ان الاحداث الثلاثة موجودة في هذا الجدول ، وطبعا في الجدول الآخر كذلك : . وهنا نقارن النتائج . جعفر Make_AuditTrail_XML_02.zip

::بسم الله نبدأ:: السلام عليكم ورحمة الله وبركاته اخوتي الكرام كل عام وانتم بخير اليوم وكما هو موضع من عنوان الموضوع موضوعنا عن ربط برنامج الاكسيس بصفحات الويب وهنا اخص لغة ال PHP كان فى سائل عن امكانية ربط برنامج الاكسيس بالنت علشان يسمح للمرضي بتحميل التقارير الخاصه بهم ورديت عليه تقريبا ان الموضوع صعب لكن اليوم اقدم لكم طريقه اتمني ان تكون سهله وواضحه واعذروني على المقدمة الطويله ورقاقة الكلمات نبدأ اولا بالادوات الازم توفرها:- 1- XAMPP يمكن تحميله من هنا 2- Connector/ODBC MYSQL يمكن تحميله من هنا ويفضل تنزيل النسخه 8.0.31 انا عن نفسي شغال بالاصدار 8.0.31 (وشغال تمام) وممكن تحمله من هنا للنسخه 32بت ومن هنا للنسخه 64بت 3- ActiveX WebBrowser control (antview) يمكن تحميل هذه الاداة من هنا او رابط مباشرة من هنا 4- PHP File's & Access File هنا يمكن تحميل الملفات التى قمت بالعمل عليها :: نبدأ بتسطيب برنامج XAMPP :: وهو المحاكي الذى سيعمل فيه بيئة ملفات ال php طبعا المفترض ان هناك دومين موجود بالفعل واستضافة والذى سيتم تنصيب الخدمه عليه وعن طريقها سيكون متاح للمريض ان يحمل تقريره لكن الموضوع هنا للتعليم فنبدأ اولا بتسطيب البرنامج ليس بالامر الصعب بل سهل جدا وحتى لا يطول الشرح اذا واجهتك مشكلة فى تسطيب البرنامج يمكن كتابة وصور المشكله او البحث فى اليوتيوب وهتلاقى الحل المناسب (لكن عموما كل ال هتعمله اوافق والتالى التالى شكرا) بعد تنصيب البرنامج وهذه واجهته ويجب يكونو هكذا هنضغط على مفتاح Explorer او نذهب الى المسار هذا C:\xampp او حسب المكان الذى سطبت البرنامج فيه هندخل على المجلد htdocs وهنا هننسخ مشروعنا ويفضل متلعبش فى الملفات التى داخل المجلد htdocs غير لو انت فاهم بتعمل ايه نرجع لموضوعنا هننسخ الملف ال اسمه LAB وهنضعه فى المجلد htdocs هنفتح المتصفح وندخل على الرابط التالى http://localhost/phpmyadmin/ وهنبدأ بانشاء قاعدة بيانات جديده وهنسميها db_lab بعدها هندخل على القاعدة التى تم انشاءها وهنعمل عمليت استيراد هنضغط على استعراض وهنروح للمسار C:\xampp\htdocs\LAB هنلاقى فى ملف نفس اسم قاعدة البيانات وبعدها هننزل تحت وهنضغط على import وبهذا نكون قد انتهينا من رفع القاعدة نذهب الى هذا الرابط ونتحقق ان كل شئ تمام http://localhost/lab/ لو ظهر لك هذا الشاشة يبقي امورك فى التمام والحمد لله اذا لا بيكون فى خطأ حصل نبدأ نسطب برنامج Connector/ODBC MYSQL (( لا يحتاج الى شرح الامر بسيط وسهل وايضا حتى لا يطول الموضوع )) من هنا هنحتاج الى تركيز الامور بسيطه لكن لازم تتعمل صح هنروح للكنترول بنل لو انت شغال على وندوز 11 لو انت شغال على وندوز 10 هنا هتختار واحد منهم حسب اصدار الاوفيس عندك 32بت ولا 64 بتحميل انا هنا اصدار 64 بت هنكتب الاعدادات كما فى الصورة بالظبط لو انت حاطط كلمة سر لل phpmyadmin هتحطها وتضغط اوك بعد ما تختار القاعده الخاصه بك وبكده نكون انتهينا من هذا الجذء نبدأ تثبيت برنامج ActiveX WebBrowser control (antview) وده ال هيكون مسؤول عن استعراض صفحات الويب داخل الاكسيس وهي اداة ممتاذه عيبه تقريبا حسب الموقع انها مش مجانيه لو فى اى احد عنده طريقة نستخدم خاصية webview2 هي موجوده فى اوفيس 365 تقريبا وحسب ما سمعت انها بتنزل متضمنه لكن فى الاصدارات ال معانا مش موجوده او اى اداة اخري تكون مجانيه 100% يبقي تمام تثبيت البرنامج لا يحتاج شرح ^_^ نرجع لملف التطبيق الاكسيس ^_^ ونفتح البرنامج عادي بعد ما تم تثبيت كل الادوات السابق ذكرها وبرنامج الاكسيس هتلاقيه فى مجلد اسمه APP ممكن تنقله لاى مكان عادي وللعلم تم اضافة مكتبة واكود QR Code اخذتها من موضوع استاذى الاستاذ @ابو جودي فى موضوع الفاتورة الالكترونية 🤲 ربنا يبارك فيه وفى جميع اساتذتى هنا 🤲 نفتح ملف الاكسيس ونتأكد ان جميع المكتبات تعمل وليس هناك اى مكتبه مفقوده نركز على الصوره التالية هنتحقق من التالى ان الجداول متصله والمطلوب انك تفتح اى جدول للتأكد انه يعمل الاتصال جيدا هنفتح النماذج اول نموذج معانا FrmGenerator_User هنا انت لو عاوز تعمل اسم مستخدم وكلمة مرور ال هيدخل بيها المريض عندك كما هو موضح من الصورة حلين اما الاكسيس يعمل اسم مستخدم وكلمة سر عشوائية (1) او انت تعمل للمريض اسم مستخدم وكلمة سر يديوية (2) بعد ما تضيف حساب المريض هيكون هنا عندك القدرة على اضافة التقارير للمريض تابع الصور التالية يمكنك تحديد اكثر من ملف هنا فى الكود يسمح لك باستعراض ملفات الصور وال pdf بعد رفعها لو هناك اى ملاحظات تريد ان تسجلها يمكن هذا هتكتب الملاحظه وتعمل حفظ 😁 التالى لو انت عاوز تحول كلمة سر الى كود هاش هذا لو فرضا انك عاوز تغير كلمة السر لحساب ما وللعلم التشفير فى نظام ال PHP تشفير بالهاش هو تشفير فى اتجاه واحد يعنى يمكن عمل مطابقة لكلمة السر مع الهاش لكن متقدرش تحول الهاش الى كلمة سر طبعا ده علشان الحماية وده سياسة التشفير فى PHP والله اعلم او لو عاوز تتحقق من كلمة السر (يعني معاك كلمة السر والهاش وعاوز تتحقق انهم مطابقين ) هتضغط على التحقق وهو هيتحققلك بعد ما تم اضافة حساب للمريض عن طريق نموذج انشاء الحسابات وتم رفع الملفات للمريض هنروح على نموذج انشاء ال QR Code هنختار اسم حساب المريض من القائمة (قائمة المرضي) ونضغط على تصدير رمز ال QR اعتقد اني شرحت كل الامور واذا كان هناك اى مشكلة اقدر احلها لا تتردد فى الاستفسار وهتلاقى الجميع هنا بيسعدك بعض الملاحظات الواجب التنبيه لها يجب ان تغير عنوان الموقع اما للدومين اذا كان لديك دومين مع تعديل مسار البرنامج اذا لزم الام او كتابة عنوان الكمبيوتر الخاص بك اذا كنت تريد التجربه علشان لما تقراء كود QR يدخلك على الصفحه بطريقة صحيحة طريقة التعديل :- هتروح على كود نموذج انشاء كود QR وتعدل على العنوان بدل 127.0.0.1 وكل عام وانتم بخير وختاما نسألكم الدعاء لوالدتي الله يرحمها والشفاء لوالدي ربنا يبارك فى صحته ولا تنسونا من صالح دعواتكم الطيبة

فى ظل امكاناتي المتواضعه وللحاجه وبعد مراجعة العديد من الحلول المتوفره على الويب التى لم اجد بها ضالتي اقدم لكم مربع التلوين هذا colorpicker حيث يقوم بتلوين خلفية النموذج بشرط تسميتها detail بالانجليزيه ورأس النموذج بشرط تسميته header وتذييل النموذج بشرط تسميته footer وكذلك مربعات التنسيق والتجميل rectangle بشرط ان يتم تسميتها box1 , box2 وهكذا وضعت وظائف التلوين فى حدث عند النقر المزدوج فى كل منها طبعا يمكن استخدام اسماء عناصر عربيه لكنها ستحتاج تعديل فى الجدول والكود ولا افضل ذلك المربعات الونيه يمكن تلوين حتى box9 اى تسع مربعات النموذج يحتوي اكثر من 400 لون معد سلفا منها 160 لون عشوائي تتغير بضغطة زر الى اخرى كل لون تختاره يمكنك التعديل عليه بتغيير قيم الالوان الاحمر والاخضر والازرق يوجد جزء خاص لضبط الخطوة فى + او - بقيم من 1 حتى 25 كما يوجد جزء خاص بتحديد سلوك تلوين الفورم فى المره القادمه التى سيفتح فيها وامامك 3 خيارات اما استخدام خياراتك الاخيرة للالوان واما استخدام الوان الجدول الافتراضيه وهى الوان رماديه يمكن تغييرها من الجدول فقط واما استعادة الوان الفورم عندما تم تصميمه ويتم التحكم فى كل جزء على حده اعلم انه بدائي لكنه يؤدي الغرض بفاعليه ونرحب بالافكار الجديده الكود متاح للجميع استخدامه شخصيا او تجاريا بشرط عدم ازاله شعار مؤسسة وعد الخيريه او كود الصوره اتمنى تزويدي بتعليقاتكم البرمجيه لتحسي الكود وتطويره لتعيين الصور كخلفيات يمكن التحميل من هنا mycolorpiker.zip

وعليكم السلام 🙂 مشاركة مع اخوي @Foksh 🙂 هذا كود تفريغ حقل البحث، اذا كان النقر على زر البحث: Me.Txt_Search = "" او Me.Txt_Search = Null او Me.Txt_Search = Empty ثم Me.Txt_Search.Setfocus . اما اذا لم يوجد زر بحث، وكان الكود يعمل البحث على حدث "بعد التحديث" لحقل البحث ، فيجب ان ننقل التركيز على اي كائن في الموذج يقبل التركيز، ثم نستعمل الكود اعلاه ، هكذا مثلا: دائما في نماذجي عندي زر لغلق النموذج اسمه cmd_close فعليه يصبح الكود: me.cmd_close.setfocus Me.Txt_Search = "" او Me.Txt_Search = Null او Me.Txt_Search = Empty ثم Me.Txt_Search.Setfocus . جعفر

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) اليوم جئتكم ببرنامج المنبه الذكي هدية بسيطة لأعضاء منتدانا الغالي وصف البرنامج :- إمكانية تغيير الثيم من داخل الساعة . إمكانية تغيير نغمة رنين المنبه . نغمة تنبيه كل ساعة . دعم للغفوة كما في أجهزة الموبايل . إمكانية تعديل مدة العفوة حسب الحاجة . إمكانية عمل تنبيه متكرر حسب اليوم ، أو التنبيه لأيام محددة . صور من المنبه الذكي :- عند فتح المنبه لأول مرة لوحة التحكم بالإعدادات واجهة المنبه شاشة وقت التنبيه شاشة ضبط المنبه شاشة عرض المنبهات الفعالة والآن مع التحميل بدايةً النسخة 64 ، وقريباً النسخة الثانية بإصدار 32 إن شاء الله :- 64.zip ملاحظة:- تم حفظ البرنامج بصيغة Accde كونه قيد التطوير والتعديل حالياً وعدناكم بإضافة جديدة وهي إضافة حالة الطقس في شاشة المنبه الذكي ، والحمد لله الذي قدرني على توظيف هذه الميزة داخل التطبيق . وكما ذكرت سابقاً الخدمة تحتاج إتصال إنترنت . من الإعدادات > قم باختيار البلد > ثم تطبيق . وسيتم الإتصال بالسيرفر تلقائياً وإدراج درجة الحرارة في شاشة المنبه الرئيسية . ملاحظة :- درجة الحرارة التي يتم عرضها حالياً هي للعواصم العربية فقط ، وسيتم العمل على إدراج معظم المدن في الدول العربية في تحديثات لاحقة . الملف مفتوح المصدر ، وأطلب منكم فقط الدعاء لوالديّ Smart Alarm.zip وباب الحوار مفتوح للمناقشة

🌼 السلام عليكم ورحمة الله وبركاته 🌼 يسرني اليوم أن أقدم لكم الإصدار الثاني والمطور من الأداة المتميزة والرائعة ( الكاتب الذكي لدوال المجال ) . Dloockup, DCount, DMax, DMin, Dfirst, DLast هذه الأسطورة التي تقوم بكتابة دوال المجال نيابة عنك بشكل آلي .. :: ما هو الجديد :: اليوم أحتفل معكم بإصدار النسخة الثانية والمطورة لهذه الأداة والتي تتميز بالإضافات التالية : 1- إمكانية إضافة عدد لا نهائي من المعايير ( الشروط ). 2- التعرف التلقائي على نوع بيانات الحقول. 3- جلب قيمة المعيار من التقارير. 4- ميزة إضافة الأقواس حول المعايير. 5- حفظ بيانات آخر عملية قمت بها. 6- كتابة الدالة بمجرد الضغط على زر Enter. 7- تم إضافة أزرار لتسهيل كتابة الدالة NZ والمعامل Like. 8- تكبير لوحة الناتج بالضغط المزدوج عليها. 🌹🍀🌹🍀🌹 وهنا تم شرح هذه الإضافات بالتفصيل : :: شرح كيفية استخدام الأداة بالتفصيل :: :: 🌼 شكر وتقدير 🌼 :: لكل من ساهم برأي أو فكرة أو تطبيق في هذا العمل ، وجزاكم الله عن المسلمين كل خير 😊🌹 :: حمل الإصدار الثاني للكاتب الذكي لدوال المجال 2.0 :: ‏‏‏‏Domain Functions Builder V2.0.accdb

برنامج طباعة الاختبارات بطريقة الاتمته (الاصدار الثاني) برمجة وتصميم الاستاذ صالح احمد محمد ربيع هذا البرنامج اهداء لجميع المدارس برنامج طباعة الاختبارات الاصدار ٢.xls

وعليكم السلام خيار آخر Sub Test() Dim a Dim i& Application.ScreenUpdating = False a = Cells(7, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2) With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If a(i, 1) & a(i, 2) <> "" And a(i, 1) <> 0 And a(i, 2) <> "" And a(i, 1) <> "" And WorksheetFunction.IsNumber((a(i, 1))) Then If Not .exists(a(i, 1) & "|" & a(i, 2)) Then .Add a(i, 1) & "|" & a(i, 2), "" End If Next Cells(7, 5).Resize(.Count) = Application.Transpose(.keys) Application.DisplayAlerts = False Cells(7, 5).Resize(.Count).TextToColumns Destination:=Range("E7"), OtherChar:="|", FieldInfo:=Array(2, 1) End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

السلام عليكم أخي الكريم جرب الكود التالي في حدث المصنف ThisWorkbook Private Sub Workbook_NewSheet(ByVal Sh As Object) Dim R As Integer, G As Integer, B As Integer Randomize R = Int(Rnd() * 256) G = Int(Rnd() * 256) B = Int(Rnd() * 256) Sh.Tab.Color = RGB(R, G, B) End Sub سيعمل الكود فقط عند إضافة ورقة عمل جديدة

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

تفضل أخي العزيز .. ولزيادة الخير وضعت لك أكواد جميع الإجراءات الأساسية : الإجراءات الإعتيادية للسجلات ( حفظ - جديد - حذف - إضافة - تكرار - التالي - السابق - الأول - الأخير - .....) '===================================== حفظ السجل والذهاب لسجل جديد Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord DoCmd.GoToRecord , , acNewRec Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== حذف السجل Private Sub DeleteBtn_Click() On Error GoTo Err_DeleteBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdDeleteRecord Exit_DeleteBtn_Click: Exit Sub Err_DeleteBtn_Click: MsgBox Err.Description Resume Exit_DeleteBtn_Click End Sub '===================================== إضافة سجل جديد Private Sub AddNewBtn_Click() On Error GoTo Err_AddNewBtn_Click DoCmd.GoToRecord , , acNewRec Exit_AddNewBtn_Click: Exit Sub Err_AddNewBtn_Click: MsgBox Err.Description Resume Exit_AddNewBtn_Click End Sub '===================================== السجل التالي Private Sub NextBtn_Click() On Error GoTo Err_NextBtn_Click DoCmd.GoToRecord , , acNext Exit_NextBtn_Click: Exit Sub Err_NextBtn_Click: MsgBox Err.Description Resume Exit_NextBtn_Click End Sub '===================================== السجل السابق Private Sub PreviousBtn_Click() On Error GoTo Err_PreviousBtn_Click DoCmd.GoToRecord , , acPrevious Exit_PreviousBtn_Click: Exit Sub Err_PreviousBtn_Click: MsgBox Err.Description Resume Exit_PreviousBtn_Click End Sub '===================================== السجل الأول Private Sub FirstBtn_Click() On Error GoTo Err_FirstBtn_Click DoCmd.GoToRecord , , acFirst Exit_FirstBtn_Click: Exit Sub Err_FirstBtn_Click: MsgBox Err.Description Resume Exit_FirstBtn_Click End Sub '===================================== السجل الأخير Private Sub LastBtn_Click() On Error GoTo Err_LastBtn_Click DoCmd.GoToRecord , , acLast Exit_LastBtn_Click: Exit Sub Err_LastBtn_Click: MsgBox Err.Description Resume Exit_LastBtn_Click End Sub '===================================== البحث عن سجل Private Sub FinedRecBtn_Click() On Error GoTo Err_FinedRecBtn_Click Screen.PreviousControl.SetFocus DoCmd.RunCommand acCmdFind Exit_FinedRecBtn_Click: Exit Sub Err_FinedRecBtn_Click: MsgBox Err.Description Resume Exit_FinedRecBtn_Click End Sub '===================================== تكرار السجل Private Sub DublicateRecBtn_Click() On Error GoTo Err_DublicateRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.RunCommand acCmdRecordsGoToNew DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste Exit_DublicateRecBtn_Click: Exit Sub Err_DublicateRecBtn_Click: MsgBox Err.Description Resume Exit_DublicateRecBtn_Click End Sub '===================================== حفظ السجل Private Sub SaveRecBtn_Click() On Error GoTo Err_SaveRecBtn_Click DoCmd.RunCommand acCmdSaveRecord Exit_SaveRecBtn_Click: Exit Sub Err_SaveRecBtn_Click: MsgBox Err.Description Resume Exit_SaveRecBtn_Click End Sub '===================================== طباعة السجل الحالي Private Sub PrintRecBtn_Click() On Error GoTo Err_PrintRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.PrintOut acSelection Exit_PrintRecBtn_Click: Exit Sub Err_PrintRecBtn_Click: MsgBox Err.Description Resume Exit_PrintRecBtn_Click End Sub '===================================== التراجع عن التسجيل Private Sub UndoRecBtn_Click() On Error GoTo Err_UndoRecBtn_Click DoCmd.RunCommand acCmdUndo Exit_UndoRecBtn_Click: Exit Sub Err_UndoRecBtn_Click: MsgBox Err.Description Resume Exit_UndoRecBtn_Click End Sub '===================================== فتح التقرير وطباعة السجل المحدد بدلالة الرقم التسلسلي Private Sub Print_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport, , "ID =" & Me.ID DoCmd.RunCommand acCmdPrintPreview DoCmd.RunCommand acCmdPrint Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: If Err.Number = 2501 Then Resume Exit_OpenReportBtn_Click 'print cancelled MsgBox Err.Number & vbCr & Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== طباعة تقرير Private Sub PrintReportBtn_Click() On Error GoTo Err_PrintReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acNormal Exit_PrintReportBtn_Click: Exit Sub Err_PrintReportBtn_Click: MsgBox Err.Description Resume Exit_PrintReportBtn_Click End Sub '===================================== معاينة تقرير Private Sub VeiwReportBtn_Click() On Error GoTo Err_VeiwReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acPreview Exit_VeiwReportBtn_Click: Exit Sub Err_VeiwReportBtn_Click: MsgBox Err.Description Resume Exit_VeiwReportBtn_Click End Sub '===================================== فتح تقرير Private Sub OpenReportBtn_Click() On Error GoTo Err_OpenReportBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OpenReport stDocName, acViewReport Exit_OpenReportBtn_Click: Exit Sub Err_OpenReportBtn_Click: MsgBox Err.Description Resume Exit_OpenReportBtn_Click End Sub '===================================== حفظ تقرير بصيغة Private Sub SendReportToBtn_Click() On Error GoTo Err_SendReportToBtn_Click Dim stDocName As String stDocName = "ReportName" DoCmd.OutputTo acReport, stDocName Exit_SendReportToBtn_Click: Exit Sub Err_SendReportToBtn_Click: MsgBox Err.Description Resume Exit_SendReportToBtn_Click End Sub

كثير من تصاميم HTML نتمنى ان تكون موجودة في الاكسس و ربما يصبح الحلم حقيقة عما قريب اضع بين يديكم فكرة ! فكرة جدول مبني بلغة HTML مع تلوين الاسطر عند المرور عليها آمل ان تنال على استحسانكم web.mdb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (E) وحفظ الملفات بداخله بصيغة (PDF) مع تنسيق الجداول بنفس التنسيق المرفق في طلبك . Public Sub Split_Sheet_condition_of_the_week() Dim dataSheet As Worksheet, weekSheet As Worksheet Dim minDate As Date, maxDate, weekStartDate As Date Dim lr As Long, c As Long, LastRow As Long, MH As Variant Dim weekSheetName As String, WS_Address As String Dim ST_DATA, ST_Name, ST_Path, ST_WS_Data As String Dim WS_Data As Range, Total_Rng As Range Dim wsData As Worksheet: Set wsData = Worksheets("تجميع") 'حدف جميع اوراق العمل باستثناء ورقة التجميع Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "تجميع" Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next Set dataSheet = wsData With dataSheet lr = .Cells(.Rows.Count, "F").End(xlUp).Row 'اصغر تاريخ minDate = Application.WorksheetFunction.Min(.Range("F2:F" & lr)) ' اكبر تاريخ maxDate = Application.WorksheetFunction.Max(.Range("F2:F" & lr)) End With weekStartDate = Date_Prev_Saturday(minDate) While weekStartDate <= maxDate 'تسمية الشيتات weekSheetName = Format(weekStartDate, "d") & " To " & Format(weekStartDate + 6, "d") With ActiveWorkbook Set weekSheet = Nothing On Error Resume Next Set weekSheet = .Worksheets(weekSheetName) On Error GoTo 0 If weekSheet Is Nothing Then 'اظافة وتسمية اوراق العمل Set weekSheet = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) weekSheet.Name = weekSheetName weekSheet.DisplayRightToLeft = True Else weekSheet.Cells.Clear End If End With 'فلترة البيانات weekSheet.Range("l1:m1").Value = Array(dataSheet.Range("F1").Value, dataSheet.Range("F1").Value) weekSheet.Range("l2:m2").Value = Array(">=" & CLng(weekStartDate), "<=" & CLng(weekStartDate) + 6) dataSheet.Range("F1:k" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=weekSheet.Range("l1:m2"), CopyToRange:=weekSheet.Range("A4"), Unique:=False weekSheet.Range("l1:m2").Clear weekSheet.Columns("A:F").EntireColumn.ColumnWidth = 16 LastRow = weekSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Set Total_Rng = Range(weekSheet.Cells(LastRow + 1, "A"), weekSheet.Cells(LastRow + 1, "F")) MH = (RGB(153, 153, 255)) ' اظافة المعادلات weekSheet.Range("F5").Formula = "=COUNTIF(تجميع!$f$2:$f$500,a5)" weekSheet.Range("F5").AutoFill Destination:=Range("F5:F" & LastRow) weekSheet.Range("E5:E" & LastRow) = "=sum(B5*D5)" Cells(LastRow + 1, 1).Value = "المجموع" For c = 2 To 6 Cells(LastRow + 1, c).Value = Application.Sum(Range(Cells(5, c), Cells(LastRow, c))) Next c 'تنسيق الجدول Total_Rng.Interior.Color = MH Total_Rng.Font.Bold = True Total_Rng.Font.Size = 13 With Range("A5:F" & LastRow + 1) .HorizontalAlignment = xlCenter .Font.Name = "Calibri" .Font.Size = 16 .Value = .Value End With 'تسطير الجدول DL = weekSheet.Range("A65500").End(xlUp).Row DC = weekSheet.Cells(5, Columns.Count).End(xlToLeft).Column Range(weekSheet.Cells(5, 1), weekSheet.Cells(DL, DC)).Borders.Weight = xlThin 'فواصل الصفحات With weekSheet.Range("A5:A" & _ weekSheet.Range("A" & Rows.Count).End(xlUp).Row) Set WS_Data = weekSheet.Cells.Find(What:="المجموع", LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext) If Not WS_Data Is Nothing Then WS_Address = WS_Data.Address Do If Not WS_Data Is Nothing Then WS_Data.Offset(1).PageBreak = xlPageBreakManual End If Set WS_Data = .FindNext(WS_Data) If WS_Data Is Nothing Then Exit Do End If If WS_Data.Address = WS_Address Then Exit Do End If Loop End If End With On Error Resume Next ActiveWindow.View = xlPageBreakPreview weekSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 ActiveWindow.View = xlNormalView ' إنشاء مجلد الحفظ ST_Name = "فرز البيانات الأسبوعية" ST_DATA = "" ST_WS_Data = "E:\" ' قم بتغييره بما يناسبك 'ST_WS_Data = "D:\" If IsEmpty(ST_Name) Then Exit Sub If IsEmpty(ST_DATA) Then Exit Sub MkDir ST_WS_Data & "\" & ST_Name ST_Path = ST_WS_Data & "\" & ST_Name & "\" & ST_DATA ' مسار وضع الشيتات بصيغة (PDF)""""""""""""""""""""""""""""" مسار مجلد الحفظ weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\فرز البيانات الأسبوعية\" & weekSheet.Name & "_" & Format(Now, "MMMM") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False weekStartDate = weekStartDate + 7 Wend dataSheet.Select MsgBox "" & ST_WS_Data & ST_Name & vbLf & vbLf & vbLf & "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy") & " " & _ FolderName, _ vbInformation, " : تم حفظ الملفات بنجاح في " On Error GoTo 0 Application.ScreenUpdating = True End Sub Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function بالتوفيق.......... تجميع V1.xlsm