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

::: السلام عليكم ورحمة الله وبركاته ::: أسمحولي أن أقدم لكم هذه الهدية 🎁 البسيطة والمميزة والرائعة من مميزات هذا الإضافة: - عرض الملاحظات المهمة والتذكيرات مثل ( إجتماع ، اختبار ، تدوين أفكار ، كتابة مسودات، التذكير بالمواعيد ، .... الخ ) على واجهة برنامجك. - تتوائم مع البرامج ذوات المستخدمين المتعددين (كل مستخدم بملاحظاته الخاصة به). - تصميم رائع وألوان جميلة . - سهلة الاستخدام . رابط الشرح على اليوتيوب : تحميل الملف: Notes.accdb :: ولا تنسوني ووالدي من صالح دعواتكم 🙂 ::

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !! وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة . الإضافات التي تم تأمينها في هذه النسخة :- التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 . إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط . إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) . استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم . واجهة محاكية وجذابة للبرنامج . لا تحتاج جداول أو مكتبات خارجية .... إلخ . تم كتابة الدوال والأكواد بطريقة تسهل على المطورين إعادة الهيكلة والتصميم حسب حاجتهم في برامجهم . واجهة البرنامج :- :- ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز . التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي المشاكل عند اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر . WhatsApp Sender 2025.zip التحديث الجديد من مرسال الواتس أب - الإصدار الثاني . يحتوي على الإضافات والتحسينات التالية :- 1️⃣ التحسينات :- تحسين التعامل مع المرفقات الأكثر من مرفق واحد ، بحيث يتم التعامل معها دفعة واحدة بدلاً من التعامل مع كل مرفق بشكل مستقل ( تقليل الوقت ) . تحسين عمليات المحاكاة للوحة المفاتيح للصق الرسالة والملفات داخل تطبيق واتس أب سطح المكتب . 2️⃣ الإضافات الجديدة :- إنشاء جداول الخدمة ( عددها 3 ) بشكل تلقائي . إضافة ميزة الإستيراد من ملفات VCF ( النسخة الإحتياطية من قائمة الأسماء من الجوال ) . بحيث يتم استيراد الأرقام والأسماء الى جدول Tbl_Contacts ، من خلال زر ، مع دعم التعامل مع الترميزات والتشفيرات المختلفة . وأيضاً الأرقام يتم تحويلها إلى صيغة دولية تلقائيًا (مثلاً: 079xxxx → +96279xxxx) . إضافة ميزة إنشاء جهة اتصال جديدة ( قيد التطوير للأفضل ) ، من خلال الزر . إضافة ميزة "إرفاق التوقيع مع الرسالة" . ويمكن التحكم بها من خلال جدول الإعدادات Tbl_SendSettings . إضافة ميزة الإرسال من دفتر العناوين ( متعدد الإختيار ) ، أو ادخال رقم هاتف بشكل يدوي . عند ادخال رقم هاتف يدوي ( محلي ) بدون مفتاح الدولة ، يتم قراءة قيمة رمز الدولة الإفتراضي من الجدول Tbl_SendSettings الخاص بالإعدادات . وعليه فسلت بحاجة لإضافة مفتاح الدولة المحلية بشكل يدوي وإلزامي . إضافة ميزة تقييد مفتاح الإيموجي من خلال جدول الإعدادات . فمنح أو رفض الصلاحية بالوصول اليه . ( قيد التطوير بحيث يتم المنع حتى من خلال لوحة المفاتيح ) . إضافة ميزة تحديد أنواع الملفات المسموح للمستخدم بإرسالها في جدول الإعدادات نفسه . إضاقة التحكم بفترة الإنتظار بين الرسالتين عند الإرسال المتعدد ( بالثواني - القيمة الإفتراضية = 2 ) . إضافة ميزة التحكم بالحد الأقصى لحجم الملفات المرفقة ( فردي أو أكثر من مرفق ) من خلال جدول الإعدادات أيضاً . إضافة رابط لتحميل نسخة برنامج واتس أب سطح المكتب من مصدره على موقع Whatsapp ، من خلال الزر . إضافة ميزة الحفظ التلقائي للأرقام الغير مخزنة في دليل الهاتف ( الجدول Tbl_Contacts ) . بحيث يتم تعريف الرقم بأنه "غير معروف" . وفي التعديلات اللاحقة سيتم إضافة ميزات لها . جميع الرسائل المرسلة ( الناجحة والغير ناجحة ) سيتم تخزينها في الجدول Tbl_Message . أيضاً في التعديلات اللاحقة سيتم إضافة ميزات لها . :- دعوة لتجربة الإستيراد من ملفات الـ VCF ، وإخباري بالنتيجة عن مدى صحة الإستيراد . السبب في سؤالي هذا هو اختلاف إصدارات هذه الملفات الناتجة عن اختلاف إصدارات أنظمة التشغيل في الهاتف الخلوي ، أو اختلاف الحصول عليها حسب البرنامج . وللعلم الـ VCF هي ملفات تستخدم لتخزين معلومات جهات الاتصال . كيف نحصل عليها :- في الأندرويد : الذهاب إلى تطبيق جهات الاتصال ثم الإعدادات ثم ابحث عن استيراد و تصدير جهات الإتصال ثم حفظ كملف VCF . في الآيفون : لا يدعم آيفون هذه الميزة ( تصدير جهات الإتصال ) إلا من خلال تطبيقات كمبيوتر مثل 3UTools وشبيهاته . 3️⃣ صور الواجهة الجديدة :- 4️⃣ تحميل الإصدار الجديد :- WhatsApp Sender 2025 V2.0.zip 😬 يوجد سطر لم أقم بحذفه سهواً أثناء التعديلات في دالة الإستيراد الرئيسية من المديول في الدالة Public Function ImportVCF . السطر :- Forms("Frm_Sender").Controls("Text0").Requery حيث أن هذا العنصر تم الإستغناء عنه . ومرفق في طيه ملف VCF تجريبي للتجربة Test VCF.zip WhatsApp Sender - V4.0.accdb.zip

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

🌷 لقاءات أكسس العرب الافتراضية | 03 | 🌷 موضوع اللقاء : مهارات وفنيات تصميم النماذج واختيار الألوان وتنسيق العناصر رابط اليوتيوب: ★ روابط اللقاء الثالث ★ ○ موقع إلهام : https://www.pinterest.com https://www.freepik.com ○ مواقع اختيار الألوان : https://coolors.co https://colorhunt.co https://www.materialpalette.com https://coolors.co/gradients ○ مواقع الأيقونات : https://icons8.com/icons https://www.flaticon.com https://icon-icons.com/ https://www.iconarchive.com/ https://flaticons.net/free-icons ○ مواقع صور PNG : https://www.cleanpng.com https://www.pngwing.com https://www.seekpng.com ○ مواقع صور خلفيات : https://www.pexels.com https://www.freepik.com/free-photos-vectors/background https://pixabay.com https://www.vecteezy.com/free-photos/background https://stocksnap.io/search/background ○ مواقع الخطوط : https://fonts.google.com https://arbfonts.com خطوط رسومية : https://www.vertex42.com/ExcelTips/unicode-symbols.html https://www.ssec.wisc.edu/~tomw/java/unicode.html ○ مراجع مهمة : https://elshemy.me/content/2025_8/Access_UI_UX_ِGuide.html ★ روابط تهمك ★ ❀ ملفات اللقاءات الافتراضية : ○ https://shorturl.at/mR2T3 ○ اللقاء الأول : https://drive.google.com/drive/folders/1wiMVugVZNzU9eaJ9abX-YfqhhSG6_Ec5 ○ اللقاء الثاني : https://drive.google.com/drive/folders/1EcaTZBp0rhmxhm7c_NKOg6BC-O89DS4W ○ اللقاء الثالث : https://drive.google.com/drive/folders/1VX4an_hg3ZdX-Q9_MlNNPoCzkCN6b98d ○ برمـجيـات - أدوات - إضـافـات : https://drive.google.com/drive/folders/1RtmH-cuk1rpj0zKkUNPbQz681oqKVNo3 ○ مجلد ورش العمل المشتركة : https://drive.google.com/drive/folders/1LL5_hsElZR4zQv62Wt1TxU2_M8Gv1Jja ❀ رابط الانظمام لمجموعة الأكسس جروب (واتسأب) : https://chat.whatsapp.com/HQvOPGrkASM2guvAotHXCw ❀ قناة أكسس العرب (اليوتيوب) : http://www.youtube.com/@ArabAccessGroup ❀ مواضيع اللقاء : المقدمة الإلهام البصري pinterest الإلهام البصري Google اختيار الألوان المناسبة تطبيق الألوان على قاعدة البيانات الأيقونات النصية الأيقونات الأيقونات - برنامج Pichon إضافة الصور المفرغة PNG تصميم الواجهات عن طريق PowerPoint حفظ التصميم من الباوربوينت واستيراده إلى الأكسس تصميم نموذج تسجيل الدخول إضافة التفاعل البصري للعناصر تفاعل بصري بالتنسيق الشرطي التأثيرات البصرية التي تطبق على الأزرار الخطوط في النماذج وتنسيقاتها الأنماط اللونية أنماط الخطوط مشاهدة ممتعة 😊🌷

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

اعمل استعلام وضع فيه هذا مع تعديل اسم الحق الذي به المبلغ واسم الجدول لديك SELECT Amount, IIf([Amount] <= 15000, [Amount] * 0.1, 15000 * 0.1) AS [10%], IIf([Amount] > 15000, ([Amount] - 15000) * 0.15, 0) AS [15%] FROM YourTableName;

السلام عليكم بريمج صغير في حجمه وادواته .. ولكنه محكم ويفي بمتطلبات عملية الحضور والانصراف واحتساب ساعات ودقائق العمل . ومع ذلك هو قابل للتطوير واضافة خدمات اخرى مثل الغيابات والاجازات والعطل والاستئذان ونحوها ومثل جعل شاشة الحضور منفصلة عن البرنامج الاساسي واشياء اخرى كثيرة لا يمكن حصرها المهم ان العمل هذا يفي بالحاجات الأساسية والضرورية ....................... عملية التحضير تتم اما بادخال المعرف يدويا ثم النقر على انتر وإما استخدام قارىء الباركود كل ذلك تم تهيئته في البرنامج .. بطاقات وكشوف الباركود المطلوب قبل العمل على البرنامج هو نسخ ملف اداة الباركود barcodex.ocx الى نظام وندوز وتسجيلها تم العمل على وندوز 64 وأوفيس 32 بت الملف موجود ضمن المرفقات ، وتم اضافة المرفق المطور ChkInNetUp ايضا .. وهو خلاصة الملاحظات والطلبات في المشاركات اللاحقة ChkInOut.rar ChkInNetUp1.rar

وعليكم السلام تفضل هذا الملف ربما يفيدك ويكون به المطلوب ان شاء الله وبالتوفيق المحطة.xlsm

اعرض الملف إمنح تطبيقك المظهر الإحترافي بإستخدام مربع حوار المهام بديل لـ MsgBox {سلسلة الأدوات المساعدة المخصصة} أرفق لك إحدى الأدوات الرائعة التي يمكن أن تغنيك عن الكثير من النماذج وتجعل رسائل التنبيه تشبه رسائل ويندوز حاولت قد الإمكان تبسيط طريقة الإستخدام وتوضيحها في التعليقات أرجو أن تنال إعجابكم مع تحياتي صاحب الملف منتصر الانسي تمت الاضافه 07/05/25 الاقسام قسم الأكسيس  

هذا البرنامج هو لحساب المواريث والوصايا بالاكسل يمكن تشغيله بالنقال الذكى ..او الحاسوب نسخة 2024 اعداد الفرضى المهندس خالد الطاهر حدادة عنوان البريد الإلكتروني khaledhadada47@gmail.com ليبيا الفرائض_الربانية_بالجداول_الالكترونية_2024.xlsx

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أقدم لكم هدية بسيطة . وهي أداة لتحويل ملفات الـ PDF الى صور ( إستخراج الصفحات الى صور قابلة للإستخدام الحر ) . مميزات الأداة :- الأداة قادرة على التعرف على خصائص ملف الـ PDF الذي تم اختياره مثل ( تاريخ الإنشاء ، عدد الصفحات ، حجم الملف ) . الأداة تعمل بسرعة وكفاءة عالية . الأداة تمت تجربتها على ملف PDF يحتوي 1500 صفحة لفحص سرعة وجودة الصور المستخرجة . الأداة تتيح للمستخدم اختيار مجلد الإستخراج بشكل يدوي ( خاص به ) أو من خلال مجلد ديناميكي يتم انشاؤه بجانب ملف الأداة . الأداة لها إضافات لاحقة ( تحديثات جديدة ) . الأداة لا تقوم بتحويل ملفات الـ PDF إلى ملفات Doc أو Docx . لأن هذه الميزة تتطلب اشتراكات مدفوعة ( رغم علمي بأنه لا يوجد برنامج أو موقع قادر وبشكل صحيح 100% على التعامل مع النصوص العربية داخل ملفات الـ PDF معلومتي قابلة للخطأ والصواب ) . لاحقاً سيتم إضافة ميزة تحويل ودمج الصور التي تم استخراجها الى ملف Doc أو Docx ، بالتعرف الديناميكي على إصدار أوفيس المثبت على الكمبيوتر للمستخدم . صورة توضيحة لعمل الأداة :- تم تسريع الصورة قليلاً لغاية تقليل الحجم بأقصى حد ممكن مع محاولة عدم التأثير على جودة الصورة واجهة الأداة :- ملف الأداة بنسختين :- نسخة 64 بت PDF Converter - 64.zip نسخة 32 بت PDF Converter - 32.zip مرفق ملف PDF تعليمي - للتحربة :- تعلم آكسيس.pdf هنا في هذه المشاركة

السلام عليكم وجدت لكم صيدا سمينا لمن يواجه صعوبة في استخدام شجرة الحسابات اسميتها الحرة .. لأنها لا تستخدم اداة ActiveX TreeView تعتبر مشكلة أداة ActiveX TreeView في الإصدارات الحديثة من Microsoft Access (خاصة مع ظهور النسخ 64-بت) من أكثر التحديات شيوعاً، لأن الأداة القديمة (MSCOMCTL.OCX) غير مستقرة، تسبب مشاكل في "المكتبات" (DLLs)، ولا تدعم بنية 64-بت بشكل أصيل. هذا هو الخيار "الاحترافي" حالياً. بدلاً من أداة خارجية، يتم استخدام وحدات نمطية (Class Modules) برمجها مطورون لتغيير شكل النماذج العادية لتشبه الشجرة تماماً باستخدام عناصر التحكم الأصلية (مثل الـ Labels والـ Textboxes) تعتبر أداة Jan Karel Pieterse (المعروفة بـ JKP TreeView) واحدة من أرقى الحلول البرمجية التي تعتمد على "الفئات" (Class Modules) لتعويض أداة ActiveX، لأنها لا تعتمد على ملفات خارجية، بل تُبنى بالكامل داخل كود VBA إليكم المثال العملي تم فيه إنشاء شجرة حسابات احترافية بدون الاعتماد على ActiveX ولمن أراد التوسع والاستفادة يوجد امثلة ومرفقات متنوعة مجانية خاصة بأكسس اصدارات قديمة وأكسل وورد .. في هذا الرابط Treeview 26-5.rar

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

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

السلام عليكم ورحمة الله تم التعديل أيضا (دائما بواسطة المعادلات) على ورقة "جداول الحراسة" التي تحتوي الجداول الفردية للحراس (معذرة لم أنتبه لها إلا الآن)... الحراسة2026 للتصحيح.xlsm

اولا شكرا لدعاؤك لي ثانيا الكود في الملف السابق يقوم بترتيب الصفحات ذات الارقام وبالتالي ستجد الصفحات الاخرى ذات الحروف وليس الارقام مستثناة وتجدها بجانب بعضها ولكن هناك احتمال الرغبة في استثناء صفخة او صفحات رقمية مثلا تريد استثناء صفخة 4 من الترتيب . هنا سيتم التعديل على الكود باظافة مصفوفة لتجميع الصفخات المستثناة كل ما عليك فعلة هو التعديل في هذا الجزء من الكود حيث اضفت لك صفحات افتراضية في الكود وليس في المصتف مثل "ملخص", "إعدادات", "تعليمات يمكنك تعديلها باي اسم او اظافة صفحات اخرى باي عدد تشاء excludedSheets = Array("الرييييسية", "تجميع", "ملخص", "إعدادات", "تعليمات") اليك الملف بالتعديل ترتيب الصفحات1.xlsm تحياتي

ما باقي بالعمر الكثير ...... وانا بدعبس بملفاتي حصلت مجموعة برمجيات كنت سويتها سابقاً منها هذا المرفق وهو يعمل لدي أحد أصدقائي وللحين مابه مشاكل .. باسوورد تحديث الجداول (1001) وباسوورد الوحدات النمطية أو الشفت (tariq1991) .... أنا برفق الفولدر كامل . القاعدة (WaitingMain 2010) بحجرة التسجيل . القاعدة (Role_CheckUp) بحجرة الكشف العام . القاعدة (Role_Consultation) بحجرة الاستشارات . القاعدة (Role_MedicalAnalytics) بحجرة العلاج الطبيعي . القاعدة (Role_Pharmacy) بالصيدلية . القاعدة (Role_Physiotherapy) بمعمل التحاليل . القاعدة (Role_Radiology) بحجرة الاشعة . .القاعدة (Role_Surgery) بحجرة العمليات . ولابد كل القواعد على شبكة واحده لأن الكل مرتبط بحجرة التسجيل . . واي استفسار أو طلب أنا حاضر . Khalifa Hospital.rar

السلام عليكم طبعا الفكره قديمه واحد الاخوه كان عامل مثلها ولاكن انا عدلت عليها بطريقه تكون سهلة وبسيطة وبدون اي شرح اليكم الببرنامج رسائل.zip

في طلبك الاول TextBox8 فقط والان تغير الطلب الى الكمبوبكس يمكن اظافة التالي الى UserForm_Initialize Dim ctrl As Control For Each ctrl In Me.Controls If TypeName(ctrl) = "ComboBox" Then ctrl.Style = fmStyleDropDownList ctrl.Locked = False End If Next ctrl برنامج المراكز الطبية 30 اغسطس.xlsm

تفضل جرب هذا بما انك لم تقم برفع ملف بالمطلوب فكان عليك استخدام خاصية البحث بالمنتدى فبه كنوز وهذا ملف اخر ارجو الإستفادة منه وهذا أيضا فيديو توضيحى للمطلوب ملف اكسيل -fifo-لمنتج واحد.xlsx

السلام عليكم ورحمة الله وبركاته كود بسيط جدا لحذف المسافة بين عبد وجميع اسماء الله الحسنى اتمنى من الله عز وجل ان ينفعنا بما علمنا ... وان يعلمنا ما ينفعنا حذف المسافة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته استاذى الجليل و معلمى القدير و والدى الحبيب الكود التالى فى وحده نمطية عامة Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function SetTimer Lib "user32" _ (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, _ ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" _ (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long #Else Private Declare Function SetTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long #End If Private lngTimerID As LongPtr Private frmTargetClock As Form Public Sub StartSystemClock(frm As Form) Set frmTargetClock = frm lngTimerID = SetTimer(0, 0, 1000, AddressOf TimerProc) End Sub Public Sub StopSystemClock() If lngTimerID <> 0 Then KillTimer 0, lngTimerID lngTimerID = 0 End If End Sub Private Sub TimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) If Not frmTargetClock Is Nothing Then frmTargetClock!lblClock.Caption = Format(Now, "hh:nn:ss AM/PM") Else StopSystemClock End If End Sub الاحدات فى النموذج Option Compare Database Option Explicit Private Sub Form_Load() Call StartSystemClock(Me) End Sub Private Sub Form_Unload(Cancel As Integer) Call StopSystemClock End Sub المرفق Clock Without Timer Event.accdb

أخواني وأساتذتي ومعلمينا ( دون استثناء ) الكثير من المواضيع التي قد تكون تطرقت الى هذا الموضوع ولكن بطرق وأشكال مختلفة . اليوم وفقط في أوفيسنا / آكسيس ، سأقدم لكم نظام كامل متكامل لإدارة الطابور والدور الذي يمكن استخدامه في أي منشئة تجارية تتعامل بهذا النظام . من المعروف أننا عندما ندخل مركز للصرافة على سبيل المثال ، فإن العميل يحصل على رقم دور مطبوع على شكل تذكرة يحتفظ بها لحين تفرغ موظف لتلبية طلبه وخدمته . وعند انتظارك كعميل لحين وصول الدور لك فإنك تراقب شاشة الدور لمعرفة أين وصل الدور لأي تذكرة . وطبعاً ما يميز هذا النظام أنك في حين لم تكن متابعاً لشاشة العرض فإن النظام الصوتي كفيل بتنبيهك أين وصل الدور ولأي شباك موظف . إلى هنا وكل هذا متاح لك اليوم مع نظام مراقبة الطابور والدور الجديد . وسنسير بشرح المكونات تسلسلاً وشرحاً وافياً ( دون الإطالة .. ) أولاً :- واجهة حجز الدور الذي سيبدأ منها العميل بأخذ دور له ، وهي ذات واجهة بسيطة فقط زر واحد ينقره العميل للحصول على رقم دوره . مرفق تالياً صورة الواجهة ، والتي تدعم بالطبع شاشة اللمس . أي أن ما على العميل فقط هو النقر على الزر "احصل على رقم دور جديد" . ثانياً :- وبعد أن حصل العميل على دوره ، سيراقب دوره في قاعة الإنتظار على شاشة عرض الأدور ، والتي بدورها ستخبر العميل الى أي شباك موظف عليه التوجه حين يحين دوره ، وطبعاً لإرضاء الرغبات قمت بإضافة ميزة الناطق الصوتي ( عربي - انجليزي "اللغة الإفتراضية" ) . أي أنه عليك - كمستخدم أو مصمم - لاحقاً تفعيل اللغة العربية الصوتية (Text-to-speech) . وهنا نقطة مهمة يجب أن نمر عليها سريعاً كي تتوضح لك عزيزي القارئ كيف يمكن تفعيل القارئ الصوتي العربي للنصوص . لذا هذا الفيديو يوضح الخطوات الأولى لإضافة اللغة العربية الصوتية إلى ويندوز 10 . النقطة المزعجة من مايكروسوفت أنه وللأسف لا يتم فعلاً إضافة هذه التثبيتات الى مكانها الصحيح في محرر الريجستري . لذا علينا فعل ذلك بالطريقة اليدوية لضمان تشغيل القارئ الصوتي العربي . لذا ولمحة سريعة سنتطرق للموضوع بشكل مختصر :- بعد الذهاب إلى محرر الريجستري + R اكتب كلمة regedit اذهب الى المسار التالي : Computer\HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\Microsoft\Speech_OneCore\Voices\Tokens قم بتصدير هذا المفتاح كاملاً الى سطح المكتب بأي اسم تريده . افتح ملف الريجستري هذا باستخدام المفكرة Notepad . قم بإزالة الجزء "_OneCore" من جميع المسارات الموجودة أمامك . احفظ الملف ، وافتحه واختر Yes - نعم من الرسالة التي ستظهر لك مرتين ( على ما أعتقد ) . مبروك عليك تفعيل الناطق العربي . لك حرية الإختيار بتفعيل اللغة العربية أو لا ، ويمكنك الإنتقال لباقي الشرح . تابع معي :- الآن جاء دور الموظفين الذي سيكون لهم جميعهم نموذج واحد بنفس الأكواد بدون أي فرق لا في الشكل ولا في طريقة العمل ، انظر الصورة لاستكمال الشرح :- صورة لواجهة الموظف ( الشباك 1 ) والأمر نفسه لباقي الموظفين . ماذا يمكن للموظف أن يفعل هنا ؟ فقط النقر على الزر الذي سيكون مفعلاً عند وجود عملاء في الإنتظار ( استدعاء التالي & عدد العملاء الذين في الإنتظار ) كما في الصورة التالية :- فقط بعد النقر سيتم استدعاء العميل الأول في الانتظار ( حسب وقت الحجز طبعاً ) الى الشباك 1 :- طبعاً من المزايا المتاحة للموظف ، تحويل عميله الى موظف آخر ( ذو اختصاص على سبيل المثال ) ... إلخ . أو أن يطلب استراحة ( عند عدم انشغاله في عميل ) بأن يكون غير متاح في هذه الفترة لتلقي العملاء .... إلخ . وأيضاً بدء وانهاء خدمة العميل . وطبعاً الأمر ينطبق على جميع الموظفين . ثالثاً :- لوحة عرض العملاء في الإنتظار ، ذات واجهة بسيطة ومريحة كالتالي :- ليس بها أي تعقيد أو أمور تتطلب اعدادات أو ضبط خاص . رابعاً :- شاشة تحكم المدير ، وبهذه الواجهة سنشرحها في نقاط .. الجهة اليمنى تمثل إحصائيات واضحة للمدير عن تفاصيل حركة الدور ... الأزرار في أسفل يمين الشاشة تمثل :- • زر مخصص لتفعيل / تعطيل الناطق الصوتي لرقم الدور . • زر تحديث يدوي = تحديث للتفاصيل الظاهرة للشاشة بشكل يدوي . • زر تعيين القيمة التلقائية للتحديث = عند النقر عليه سيتم اظهار قائمة بسيطة تمثل رقم الدقائق التي تريد للنظام أن يتم تحديثه بشكل تلقائي دون الحاجة الى التحديث اليدوي . • زر إنهاء جميع العملاء العالقين = للطوارئ في حين حدوث أي خلل أو انقطاع الكهرباء أو الخروج لأي موظف دون انهاء عميله ، أو وجود عملاء لهم حجز وليسوا موجودين ... إلخ . الجهة اليسرى العلوية وتمثل العملاء الذين في الانتظار ( رقم الدور و الوقت الذي تم الحجز فيه ) . الكومبوبوكس الذي يمثل الموظفين المتاحين الآن ، وعند اختيار اي موظف سيتم عرض حالته ( متفرغ - في استراحة - يخدم عميل رقم .. ) وهنا تأتي صلاحيات المدير بأن يقوم بتحويل عميل هذا الموظف الى عميل محدد أو إعادته إلى حالة الإنتظار ( وهنا سيكون لهذا العميل الحق بالوصول لأول موظف متفرغ "VIP" ) .أو أن يتم من الإدارة إنهاء خدمة العميل الذي يخدمه الموظف الذي تم اختياره . إمكانية عرض الساعة باللغتين العربية والإنجليزية عند النقر على الساعة فقط . تم تقسيم قاعدة البيانات الى قواعد امامية وقاعدية بيانات خلفية ( للجداول المشتركة ) . وميزات كثيرة ستجدونها في هذا العمل المتواضع . Queue Management System.zip الإصدار الجديد 1.30

السلام عليكم ورحمة الله وبركاته الأخوة والأخوات الكرام تحية طيبة وبعد،،، يوجد بالمرفقات ثلاث ملفات بعد فك الضغط 1- نموذج الـ Html باسم {ahmosAutoHtmlTemplate_V10} وتحتاج إليه فقط اذا اردت التعديل او اضافة اي شي للنموذج بشكل دائم ولإضافتة داخل البرنامج : - قم بنسخ كامل المحتوي ثم قم بتشغيل الكود التالي : [Call splitAutoTableSections] 2- ملف نصي باسم {Text_Table_Sample} ويستخدم بنسخ محتواه ثم الضغ علي الزر [Convert Copied Text To html] بالنموذج يتضمن هذا الملف مثال لجدول محدد بالعلامات التالية \t ---> vbTab علامة الفصل بين الأعمدة \n ---> vbLf علامة فصل السطور داخل الخلية \r\n -> vbNewLine علامة السطر الجديد 3- البرنامج باسم {Ahmos_AutoHtmlTable} يقوم البرنامج بتحويل الجداول الداخلية باستخدام استعلامات الـ SQL الي صفحة ويب و اي جدول خارجي عن طريق نسخ الجدول بالكامل او إذا كان الجدول علي شكل نص تم تجميعة برمجياً يوجد أمثلة كما يمكنك التجربة علي اي ملف اكسيل مع بعض الصور بعض أهم النقاط : 1- داخل هذه الوظيفة { Public Function autoTblBody } يتم معالجة محتوي الخلية للجداول الخارجية وهنا تم إضافة بعض المعاير مثل إذا كان المحتوي رقم اقل او بساوي 5 يتم توسيطة داخل الخلية اذا كانت القيم TRUE or False / YES or No يتم التوسيط وتغير اللون إذا كانت بداية الخلية = او ' يتم إزالتها وكذلك الوظيفة الخاصة بالجداول الداخلية { Public Function sqlToHtmlTbl } 2- يمكن إضافة عمود فارغ علي صفحة الـ HTML باستخدام addRecNumField = True وهو يضيف عمود recNum وفائدة هذا العمود يوجد وظيفة داخل الـ JavaScript تقوم بعمل ترقيم تلقائي لهذا العمود يتم الترقيم التلقائي عن 1- فتح الصفحة 2- عند التصدير وذلك حتي يتم تعدل الارقام علي الصفوف الظاهرة فقط 3- عند عمل إلي للتصفية Clear Filters الوظيفة هي function renumberTableColumn(columnHeadName, filterOnly = false) ويمكن ان تستخدم لترقيم اي عمود بكتابة اسم العمود بدل من columnHeadName هكذا 'recNum' اما filterOnly تحدد إذا كنت تريد ترقيم الصفوف الظاهرة فقط ام كامل الصفوف false كامل الصفوف true الظاهرة فقط اي ما يتبقي بعد البحث او التصفية 3- وظيفة saveTable تمكنك من حفظ الصفحة مرة اخري وفائدتها هي ان تقوم بحفظ نسخة اخري من الصفحة بعد حذف أعمدة او تصيفة صفوف function saveTable(deleteHiddenRows = true) وهي بشكل افتراضي تقوم بحذف الصفوف الغير ظاهرة من النسخة وليس من الأصل 4- ستجد Optional ByVal constFileName As String = "", _ داخل الوظيفة { strTbltToHtml و sqlTbltToHtml } ويسخدم هذا في تعديل هذه القيمة داخل نموذج الـ Html $fileName$ <span id="fileName" style="display: none;">$fileName$</span> وفائدتة هي وجود وظيفة في الـ java script {getExportFileName} تقوم بتحديد اسم الملف عند التصدير وتقوم بإضافة الوقت والتاريخ له فاذا كانت القيمة هنا $fileName$ او فارغة سيتم استخدام قيمة افتراضية [ahmosExTable] وغير ذلك ستسخدم أغلب وظائف الـ java script قمت بها بمساعدة الـ AI ولكن الحمد لله فاهمها بنسبة كبيرة 😁 بالتوفيق Ahmos_AutoHtmlTable_Files.zip

السلام عليكم أسوق لكم تجربتي الطازجة : انا استخدم وندوز 10 قبل يومين وعند اقلاع الحاسوب اظهر على الشاشة ( الجحش وندوز ) واعذروني على الوصف .. أظهر على الشاشة امامي انه سوف يقوم بالتحديث لم يعطني خيارا للرفض .. لا يوجد الا زر واحد للمتابعة قلت ماشي يمكن يريد يحدث ملفات النظام لوجود خلل بها الجحش ركب لي وندوز 11 تصفحته .. حلو .. الوان جميلة .. وتبويبات لها اول وليس لها آخر في وندز 10 كان كل شيء بجانبي وسهل الوصول اليه .. اما هذا فيحتاج الى خطوات وقوائم واحدة خلف الأخرى من اجل اصل الى الخصيصة المطلوبة صحيح انه مطور لخاصية اللمس ، ولكني رجل عجوز .. اعتدت على كل شيء قريب مني اسلمت أمري الى الله .. وقلت اتعايش معه واصبر واتحمل حتى اعتاد عليه .. لن أكون اضعف ممن اخذ على ام اولاده ، فتاة عروسا وروضها للعلم الملف الذي يتم تحزيمه accde على 11 لا يعمل على 10 ولكنه اليوم ركز رأسه في الجدار وقال لي : ربي وربك واحد لن اجعلك تهتني في عروسك الجديدة بدأت الملفات تومض وترتعش كأن بها حمى ولم اتمكن من فتحها . اتصلت بأهل العلم والخبرة فأفادوني ان كل هذه الافاعيل من برنامج الحماية المدرج ضمن وندوز وأشاروا علي بالتراجع .. الى الاصدار السابق .. حيث يوجد ايقونة في النظام خاصة بهذا الشان تسمح بالاستعادة الحمد لله طبقت النصيحة ورجعت الى دياري سالما .

كل عام وجميع منتسبي منتدانا الغالي (أوفيسنا) بخير وصحة وعافية أعاده الله علينا وعليكم وعلى أمتنا الاسلامية بالخير واليمن والبركات.

إلى أصحاب الفضل علينا؛ إلى من علمونا؛ وما زلنا نتعلم منهم منتدى أوفيسنا (Excle) الكرام الأستاذ الفاضل / @أ / محمد صالح الأستاذ الفاضل / @ابراهيم الحداد الأستاذ الفاضل / @Ali Mohamed Ali الأستاذ الفاضل / @عبدالله بشير عبدالله الأستاذ الفاضل / @محمد هشام. الأستاذ الفاضل / @Foksh السلام عليكم ورحمة الله وبركاته جميعا كل عام وأنتم جميعا بخير وصحة وسعادة بمناسبة عيد الأضحى المبارك أعاده الله عليكم وعلينا وعلى الأمة الإسلامية بالخير واليمن والبركات ملحوظة: (الأسماء مرتبة تصاعديا منذ أول رد علينا)

السلام عليكم ورحمة الله وبركاته هذا تحديث بسيط ومهم في نفس الوقت على هذه الأداة الجميلة 🙂 ( عون المثابر في الحصول على أسماء العناصر (الإصدار 3.0)) كما علمتم هذه الأداة صممتها بفضل الله في أكسس تقوم بإحضار وسرد أسماء العناصر لك لكي تستطيع نسخها ولصقها في أي مكان تريد بكل سهولة ويسر 🙂 شخصيا أستفدت كثيرا منها وسهلت علي الكثير من الجهد وقلصت من وقت العمل بحمد الله وفضله. :: ما الجديد في النسخة 3.0 :: تم إضافة خانة في الأخير خاصة بالجداول فقط .. : وهي عند اختيار الجدول يتم كتابة جمل SQL أستعلامات أساسية للجدول المختار مع ذكر أسماء حقول الجدول مع مراعاة أنواع الحقول وكتابتها بشكل سليم في الكود .. طبعا الأداة ستعطيك الجمل الاستعلامية الأربعة SELECT, INSERT INTO, UPDATE ,DELETE والكود الناتج جاهز للصقه مباشرة في محرر الأكواد VBA .. عليك فقط أن تقوم ببعض التعديلات الطفيفة كإزالة الحقول الزائدة أو الغير مستهدفة وكذلك تحديد الشرط Where في حال التحديث أو الحذف مثلا . :: لقطة للنسخة 3.0 :: وهذا مثال على جمل ال SQL الناتجة : ' SELECT statement Dim sqlSelect As String sqlSelect = "SELECT [ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB]" sqlSelect = sqlSelect & vbCrLf & " FROM [SampleTable]" '============================================================ ' INSERT INTO statement Dim sqlInsert As String sqlInsert = "INSERT INTO [SampleTable] ([ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB])" sqlInsert = sqlInsert & vbCrLf & " VALUES (" & var_ID & ", '" & var_FirstName & "', '" & var_LastName & "', '" & var_Gender & "', " & var_Age & ", '" & var_Email & "', '" & var_Phone & "', '" & var_Education & "', '" & var_Occupation & "', " & var_Salary & ", " & var_StaffNumber & ", " & IIf(var_IsActive, -1, 0) & ", #" & var_DOB & "#)" '============================================================ ' UPDATE statement Dim sqlUpdate As String sqlUpdate = "UPDATE [SampleTable]" sqlUpdate = sqlUpdate & vbCrLf & " SET [ID] = " & var_ID & ", [First Name] = '" & var_FirstName & "', [Last Name] = '" & var_LastName & "', [Gender] = '" & var_Gender & "', [Age] = " & var_Age & ", [Email] = '" & var_Email & "', [Phone] = '" & var_Phone & "', [Education] = '" & var_Education & "', [Occupation] = '" & var_Occupation & "', [Salary] = " & var_Salary & ", [StaffNumber] = " & var_StaffNumber & ", [IsActive] = " & IIf(var_IsActive, -1, 0) & ", [DOB] = #" & var_DOB & "#" sqlUpdate = sqlUpdate & vbCrLf & " WHERE [SomeField] = SomeValue" '============================================================ ' DELETE statement Dim sqlDelete As String sqlDelete = "DELETE FROM [SampleTable]" sqlDelete = sqlDelete & vbCrLf & " WHERE [SomeField] = SomeValue" الشرح القديم للأداة على اليوتيوب 🙂 متابعة ممتعة 😊👌🏼 ولا أستغني عن آراءكم وملاحظاتكم .. 🙂 لتحميل الملف :

السلام عليكم ورحمة الله وبركاته 🙂🖐 يقول المثل : أن تأتي متأخرا خير من أن لا تأتي 😅✌ بعد جهد جهيد إنتهيت من تصميم نظام تسجيل دخول + نظام صلاحيات متطور كلما أخطو فيه خطوة أجد أنه ناقص وتطلع أفكار جديدة .. 😅👊 لذلك قلت سأنزلها كما هي الآن .. حاولت تبسيطه للمستخدم والمستفيدين منه لاحقا قدر المستطاع .. وسأبدأ بواجهة تسجيل الدخول المتواضعة : المزايا : حفظ بيانات دخول المستخدم (اختياري) الدخول مباشرة بمجرد كتابة كلمة المرور بشكل صحيح (تسريع عملية الدخول) ملاحظة : جميع كلمات المرور في البرنامج : 123 ثانيا الواجهة الرئيسية : يتم تطبيق الصلاحيات للمستخدم بمجرد تسجيل الدخول .. ثالثا : إدارة المستخدمين هنا يتم إدارة جميع ما يتعلق بمستخدمي البرنامج ( إضافة ، تعديل ، حذف ، تعيين الصلاحيات ) رابعا : إدارة مجموعات العمل والصلاحيات لكل مجموعة هنا يتم ضبط الصفحات المسموح لكل مجموعة دخولها والصلاحيات الخاصة بكل صفحة .. ومثل ماهو واضح يمكن إضافة النماذج أو إزالتها كما يحلو لك وبعد ضبط مجموعات العمل يتم تعيين كل مستخدم للمجموعة الخاصة به ، ويمكن عمل مجموعة خاصة لشخص واحد فالخيارات غير محدودة .. 🙂 الآن يمكنك الخروج من البرنامج ثم تجربة تسجيل الدخول باسم المستخدمين المسجيلين في البرنامج للاستمتاع بتجربة الصلاحيات الممنوحة لكل مستخدم 😊 وبعد الدخول للصفحات يتم تطبيق الصلحيات الخاصة بالنموذج أيضا .. وبقية الصلاحيات ستظهر حسب الزر الذي يتم الضغط عليه مزايا إضافية موجودة في البرنامج .. ولها علاقة بالأمان أيضا .. نظام النسخ الاحتياطي وله إعدادات خاصة به (نسخ احتياطي يدوي أو تلقائي ) وهو موجود في صفحة إعدادات البرنامج : ولكل مستخدم مجموعة خيارات يمكنه التحكم بها مثل ( تغيير كلمة المرور ، التشغيل عند إقلاع الجهاز ، إنشاء اختصار في سطح المكتب ، حفظ بيانات التسجيل لتسريع الدخول للبرنامج) هذه هي أهم الميزات التي يحتويها البرنامج 🙂 ولفتح البرنامج في وضع التصميم ، حتى هذي سهلة للمبرمج 😅🖐 في صفحة تسجيل الدخول وكذلك الصفحة الرئيسية يوجد هذا الزر الخاص بالمبرمج >> بعد الضغط عليه >> أدخل كلمة المرور : 123 ويمكنك تغييرها من الكود الخاص بالزر .. بتظهر لك هذي النافذة الخاصة بالمبرمج فقط : وأهم ما فيها : (1) عرض الشريط العلوي ونافذة الأكسس >> بعد تفعيله تحفظ وتشغل الماكرو وبتنفتح عندك واجهة الأكسس >> أعد تشغيل البرنامج من جديد للحصول على جميع الميزات. (2) اسم نموذج البداية >> وهو أو نموذج بيشتغل معاك في البرنامج >> وهذا يسهل على المبرمج تطبيق النظام على أي برنامج آخر 🙂 (3) اسم البرنامج (واللي ييظهر في الشريط العلوي للأكسس) : (4) رقم الإصدار (نسخة البرنامج) وتاريخها >> ويمكن الاعتماد عليها لتحديث البرنامج لاحقا .. (5) إدارة نماذج الصلاحيات >> وهي النماذج اللي ستسمح بإعطاء صلاحيات لدخولها للبرنامج .. وكذلك تعطي كل نموذج اسم صديق للمستخدم وسيتم استخدام المسمى الحقيقي للنموذج داخليا .. وهكذا أكون شرحت لكم أهم المميزات ويتبقى نقطة مهمة وهي : يمكن للمبرمج الآن الاستفادة من هذا الملف فهو قاعدة جاهزة لإنطلاق في تصميم برنامجك الخاص .. جميع الأكواد الخاصة بالصلاحيات ستجدها في الموديول التالي : وأهم ما ستحتاج معرفته في كيفية تطبيق الصلاحيات ذكرته في الملاحظات المكتوبة أول الموديول : ' (1) : لتطبيق صلاحية فتح النماذج وصلاحيات الإضافة والتعديل والحذف تضع الأسطر التالية أول الأكواد في حدث فتح النموذج '------------------------------------------------------------------------------- 'Private Sub Form_Open(Cancel As Integer) ' ' فحص صلاحة دخول النموذج ' Cancel = Not Permission_OpenForm(Me.Name, True) ' ' تطبيق صلاحيات : الإضافة / التعديل / الحذف ' Apply_Addition_Edits_Delete_Permissions (Me.Name) 'End Sub '------------------------------------------------------------------------------- ' (2) : لتطبيق صلاحيات الطباعة والاستيراد والتصدير داخل نموذج معين تكتب هذه الأسطر لمعرفة وجود الصلاحة من عدمها ' : وكل سطر من هذه الصلاحيات يرجع لك النتيجة كما يلي ' True : مسموح ' False : ممنوع '------------------------------------------------------------------------------- ' 1- فحص صلاحية الطباعة (True/False) ' Permission_Print(Me.Name , True) ' |_>> (True/False) : هذه الجزئية اختيارية لعرض رسالة تنبيه عند عدم وجود صلاحية من عدمها ' 2- فحص صلاحية الاستيراد (True/False) ' Permission_Import(Me.Name , True) ' |_>> (True/False) : هذه الجزئية اختيارية لعرض رسالة تنبيه عند عدم وجود صلاحية من عدمها ' 3- فحص صلاحية التصدير (True/False) ' Permission_Export(Me.Name , True) ' |_>> (True/False) : هذه الجزئية اختيارية لعرض رسالة تنبيه عند عدم وجود صلاحية من عدمها '------------------------------------------------------------------------------- والنماذج الموجودة في البرنامج مع أزرارها تم تطبيق الأكواد عليها بشكل عملي << راجعها وأدرسها لمعرفة كيفية عملها .. وهي سهلة يسيرة بفضل الله 🙂 وهذا مثال عملي لتطبيق الصلاحية على زر الطباعة (فتح التقرير) مثلا : وهكذا بقية الصلاحيات (اطلع على بقية الموديول) تم تحويلها لأسطر قليلة بسيطة للاستفادة منها بكل يسر .. 🙂 وأخيرا تحميل البرنامج :: Moosak ‏‏Login System with permissions 1.0.zip :: وآخر دعوانا أن الحمد لله رب العالمين ::

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

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

و عليكم السلام ورحمة الله وبركاته __اصناف مشتريات - نسخة2.xlsx

وعليكم السلام ورحمة الله وبركاته الى جانب الحلول التي ارفقها استاذنا الفاضل hegazee اليك حل اخر بالكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim rngF As Range, rngG As Range Dim rngB As Range, rngC As Range Dim pos As Variant Set rngF = Me.Range("F2") ' Set rngG = Me.Range("G2") Set rngB = Me.Range("B2:B1000") Set rngC = Me.Range("C2:C1000") If Not Intersect(Target, rngF) Is Nothing Then Application.EnableEvents = False pos = Application.Match(rngF.Value, rngB, 0) If Not IsError(pos) Then rngG.Value = Application.Index(rngC, pos) Else rngG.Value = "" End If Application.EnableEvents = True End If rngG.Select End Sub data.xlsb

السلام عليكم خسب المثال المرفق يبدو أنك تريد دالة للتقريب إلى أقرب 0.1 (أعشار)، وليس معادلة باقي القسمة (mod) التي تعمل عادة مع الأعداد الصحيحة. =CEILING(A2; 0.1) =ROUNDUP(A2*10;0)/10 تقريب.xlsx

وعليكم السلام ورحمة الله وبركاته المشكلة الرئيسية هي في منطق البحث البحث عن الأعمدة يتم من الصف 3 (G3:U3) ولكن البيانات تبدأ من الصف 4 الإزاحة (offset) غير صحيحة عند استخراج القيم اليك التعديل تنسيق ترتيب الجداول الكمية مع اسم الصنف مع التاريخ التابع له - Copy - Copy.xlsm

السلام عليكم و رحمة الله و بركاتة الزملاء الكرام وأعضاء المنتدى الموقرين، تحية طيبة وبعد، نتشرف بإبلاغكم، بفضل الله وتوفيقه، اكتمال المرحلة التطويرية النهائية لتطبيقنا المبارك: [القرآن الكريم]. نأمل أن يكون هذا العمل وقفاً رقمياً مستداماً، وأن يكتب أجره لمن ساهم في إنجازه مادياً وتقنياً. دعوة للمراجعة الفنية وضمان الجودة (Quality Assurance): قبل الإطلاق الرسمي والتعميم، ندعوكم، خاصةً من ذوي الخبرة التقنية والمستخدمين المتمرسين، لتحميل النسخة التجريبية والمشاركة في مراجعتها بدقة وعمق. إن الهدف الجوهري من هذه المرحلة هو: ضمان جودة الأداء: والتأكد من توافق التطبيق مع المعايير التقنية واحتياجات شرائح المستخدمين المتنوعة. تحديد نقاط التحسين: واكتشاف أي مواطن خلل أو قصور فني ووظيفي يتطلب تعديلاً. تحقيق التكاملية: للوصول إلى أفضل تجربة مستخدم ممكنة. نؤكد استعداد فريق العمل لدمج وتطبيق الملاحظات البنّاءة التي تصب في مصلحة الهدف العام للتطبيق، مع الالتزام التام بإعادة نشر النسخة المحسّنة والموثقة لجميع المساهمين والجمهور، تحقيقاً لمبدأ "الصدقة الجارية والمنفعة العامة". ختاماً، ندعو المولى عز وجل أن يتقبل هذا الجهد المشترك وأن يجعله في ميزان حسنات كل من شارك في بناء هذا العمل وفي تحسينه ونشره. مع خالص التقدير والامتنان، حسين الحمادي ابو يوسف القران الكريم.xlsm

و عليكم السلام ورحمة الله و بركاته انشيء ملف جديد و وأضبطه كما تريد من حيث الحجم و الهوامش و كل شيء بعدين احفظ الملف باسم مثلا A4 وبصيغة Excel Template (*.xltx) الحفظ يكون في المسار التالي C:\Users\[اسم المستخدم]\Documents\Custom Office Templates لما تنشئ ملف جديد اختار القالب اللي أنت عملته اللي هو A4

وعليكم السلام ورحمة الله وبركانه اليك التصحيج Sub Filter_Class2() Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD") Dim D1 As Object, D2 As Object, D3 As Object, D4 As Object Dim I As Long, x As Long, Y As Long, m As Long, z As Long Dim Réf As Variant, ky As Variant, Rng As String Set D1 = CreateObject("Scripting.Dictionary") Set D2 = CreateObject("Scripting.Dictionary") Set D3 = CreateObject("Scripting.Dictionary") Set D4 = CreateObject("Scripting.Dictionary") x = 0: Y = 0: m = 0: z = 0 With WSdest Application.ScreenUpdating = False .Range("M4:V32,X4:AG32,AI4:AR32,AT4:BC32").ClearContents I = 7 Do While I <= .Rows.Count If .Cells(I, 2) <> "" Then Rng = Left(Trim(.Cells(I, 2).Value), 1) Réf = Application.Transpose(.Cells(I, 2).Resize(, 13).Value) Réf = Application.Transpose(Réf) Select Case Rng Case "4" D4(z) = Join(Réf, "*") z = z + 1 Case "3" D3(Y) = Join(Réf, "*") Y = Y + 1 Case "2" D2(x) = Join(Réf, "*") x = x + 1 Case "1" D1(m) = Join(Réf, "*") m = m + 1 End Select I = I + 1 Else Exit Do End If Loop m = 4 If D4.Count > 0 Then For Each ky In D4.Keys .Cells(m, "M").Resize(, 13).Value = Split(D4(ky), "*") m = m + 1 Next ky End If m = 4 If D3.Count > 0 Then For Each ky In D3.Keys .Cells(m, "X").Resize(, 13).Value = Split(D3(ky), "*") m = m + 1 Next ky End If m = 4 If D2.Count > 0 Then For Each ky In D2.Keys .Cells(m, "AI").Resize(, 13).Value = Split(D2(ky), "*") m = m + 1 Next ky End If m = 4 If D1.Count > 0 Then For Each ky In D1.Keys .Cells(m, "AT").Resize(, 13).Value = Split(D1(ky), "*") m = m + 1 Next ky End If .Range("M4").CurrentRegion.Value = .Range("M4").CurrentRegion.Value .Range("X4").CurrentRegion.Value = .Range("X4").CurrentRegion.Value .Range("AI4").CurrentRegion.Value = .Range("AI4").CurrentRegion.Value .Range("AT4").CurrentRegion.Value = .Range("AT4").CurrentRegion.Value Application.ScreenUpdating = True End With End Sub 1تعداد.xlsm

السلام عليكم كود طباعة وكود تحويل pdf Sub Print_Managers_Deputies() Dim wsData As Worksheet, wsReport As Worksheet Dim lastRow As Long, i As Long Dim idVal As String, roleVal As String Application.ScreenUpdating = False Application.EnableEvents = False Set wsData = ThisWorkbook.Sheets("data") Set wsReport = ThisWorkbook.Sheets("التقرير مدير وكيل") lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow idVal = wsData.Cells(i, "A").Value roleVal = wsData.Cells(i, "E").Value If (InStr(1, roleVal, "مدير", vbTextCompare) > 0) _ Or (InStr(1, roleVal, "وكيل", vbTextCompare) > 0) Then wsReport.Range("L2").Value = idVal wsReport.PrintOut wsReport.Range("L2").Value = 1 End If Next i MsgBox "تمت طباعة جميع المديرين والوكلاء.", vbInformation Application.ScreenUpdating = True Application.EnableEvents = True End Sub Sub sav_PDFall2() Dim wsData As Worksheet, wsReport As Worksheet Dim lastRow As Long, i As Long Dim roleVal As String Dim folderPath As String, pdfPath As String Dim safeName As String Application.ScreenUpdating = False Application.EnableEvents = False Set wsData = ThisWorkbook.Sheets("data") Set wsReport = ThisWorkbook.Sheets("التقرير مدير وكيل") wsReport.Unprotect password:="0" folderPath = ThisWorkbook.Path & "\التقرير مدير وكيل" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow roleVal = wsData.Cells(i, "E").Value If (InStr(1, roleVal, "مدير", vbTextCompare) > 0) _ Or (InStr(1, roleVal, "وكيل", vbTextCompare) > 0) Then wsReport.Range("C9").Value = wsData.Cells(i, "B").Value safeName = wsReport.Range("C9").Value safeName = Replace(safeName, "/", "-") safeName = Replace(safeName, "\", "-") safeName = Replace(safeName, ":", "-") safeName = Replace(safeName, "*", "-") safeName = Replace(safeName, "?", "-") safeName = Replace(safeName, """", "-") safeName = Replace(safeName, "<", "-") safeName = Replace(safeName, ">", "-") safeName = Replace(safeName, "|", "-") pdfPath = folderPath & "\" & safeName & ".pdf" wsReport.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=pdfPath, _ Quality:=xlQualityMinimum, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End If Next i MsgBox "تم حفظ جميع ملفات PDF للمديرين والوكلاء في:" & vbCrLf & folderPath, vbInformation wsReport.Protect password:="0" Application.ScreenUpdating = True Application.EnableEvents = True End Sub الملف طباعة وظائف محددة.xlsm

اشارة الى الموضوع وكذلك الموضوع التالى وبناء على طلب احد الاخوة الافاضل بعمل التعديل على قاعدة بيانات الخاصة بالمعلمين لطريقة برايل واشارة سريعة للطريقة للتعريف بالقاعدة وبالطريقة المعلم المبصر هو من سوف يستخدم هذا التطبيق فى التعليم وهو من سوف ينقر ازرار الحروف والمتلقون للعلم هم من سوف يستمع لحركة كل حرف ترجمة الحرف هذه هى طريقة برايل تعتمد الطريقة على ان كل الحروف تتكون من خلية من ست نقاط وعدد النقاط بترتيب معين داخل الخلية يدل على كل حرف وهذا شكل الخلية وتتم قراءة النقاط البارزة/المحفورة من خلال معرفة رقم موضعها طبقا للخلية الاتية من خلال التحسس باللمس من إخواننا الغير مبصرين وجدول برايل اجمالا يعنى عندما يتحسس غير المبصر ويجد النقطة البارزة/المحفورة طبقا للترتيب فى الخلية الاتية رقم 1 اى ان هذا حرف الاف وهندما يتحثث النقاط البارزة/المحفورة ويجدها حسب موضعها 2 ، 3 ، 4 ، 5 فهذا حرف التاء كان الملطلوب منى تعديل النموذج ليمثل محاكاة حقيقية لشكل الخلية ومواضع الحروف عليها عند النقر على كل حرف وبحمد الله وبفضله تم عمل ذلك وهذه صورة من داخل النموذج Braille V.3.zip

السلام عليكم ورحمة الله وبركاته 🌹 بكل فخر وسعادة، تتقدم إدارة منتديات أوفيسنا وكافة أعضائها الكرام بأحرّ التهاني والتبريكات للأخ العزيز فادي @Foksh بمناسبة ترقيته إلى درجة مشرف 👏🎖️ لقد أثبت حضورك وجهودك الملحوظة في دعم الأعضاء وتقديم الفائدة باستمرار، وكان لعطائك بصمة واضحة في رُقي المنتدى وتطوره 📈💡 ✨ نبارك لك هذه الترقية المستحقة، ونتمنى لك كل التوفيق والنجاح في مهامك الجديدة ضمن كوكبة الإشراف في فريق الموقع 🌟 🌟 أهلاً وسهلاً بك في فريق أوفيسنا، واثقين بأنك ستواصل تميزك وتألقك بإذن الله 🌈 مع أطيب التحيات والتقدير، إدارة منتديات أوفيسنا 💼🌟

دالة InStr من أهم وأقوى الدوال المستخدمة في التعامل مع السلاسل النصية تستخدم لتحديد موضع أول ظهور لسلسلة فرعية داخل سلسلة نصية أخرى يمكن الاعتماد عليها في التحقق من وجود رموز أو مقاطع نصية داخل محتوى مثل: التحقق من وجود امتداد ملف البحث عن كلمة في اسم ملف فحص تنسيقات أو كجزء من معالجة متقدمة للنصوص الشكل العام: InStr(Start, String1, String2 , Compare) شرح المعاملات: Start (اختياري): >>---> رقم الموضع الذي تبدأ منه عملية البحث في String1 (يبدأ من 1) String1: >>---> السلسلة الأساسية التي يتم البحث بداخلها String2: >>---> السلسلة الفرعية المطلوب العثور عليها Compare (اختياري): >>---> نوع المقارنة يمكن استخدام: vbBinaryCompare (افتراضي): مقارنة حساسة لحالة الأحرف vbTextCompare : مقارنة تتجاهل حالة الأحرف الناتج: ترجع الدالة رقم موضع أول تطابق (Starting from 1) أو 0 إذا لم يتم العثور على أي تطابق أمثلة توضيحية شاملة 1- اختبار حالات مختلفة للدالة InStr Dim strText As String Dim strSearch As String Dim intStart As Integer Dim intResult As Integer ' البحث عن أول ظهور للحرف "a" strText = "Mohesam" strSearch = "a" intStart = 1 intResult = InStr(intStart, strText, strSearch) 'M o h e s a m '1 2 3 4 5 6 7 Debug.Print "الحالة 1: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث من موقع مختلف intStart = 4 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 2: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث عن حرف غير موجود strSearch = "z" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 3: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' البحث في نص فارغ strText = "" strSearch = "a" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 4: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث عن كلمة داخل جملة strText = "Access VBA" strSearch = "VBA" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 5: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث المتكرر لنفس الكلمة strText = "abcabcabc" strSearch = "abc" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 6: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث من منتصف السلسلة intResult = InStr(5, strText, strSearch) Debug.Print "الحالة 7: InStr(5, """ & strText & """, """ & strSearch & """) = " & intResult ' البحث مع اختلاف حالة الأحرف strText = "TestCase" strSearch = "case" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 8: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult & " (Compare = Binary افتراضي)" ' استخدام vbTextCompare لتجاهل حالة الأحرف intResult = InStr(1, strText, strSearch, vbTextCompare) Debug.Print "الحالة 9: InStr(1, """ & strText & """, """ & strSearch & """, vbTextCompare) = " & intResult Public Sub TestInStrFunction() Dim strText As String Dim strSearch As String Dim intStart As Integer Dim intResult As Integer Debug.Print String(70, "=") Debug.Print "اختبار دالة InStr" Debug.Print String(70, "=") ' الحالة 1: البحث عن حرف موجود من البداية strText = "Mohesam" strSearch = "a" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 1: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 2: البحث بعد الموضع الابتدائي intStart = 4 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 2: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 3: البحث عن حرف غير موجود strSearch = "z" intStart = 1 intResult = InStr(intStart, strText, strSearch) Debug.Print "الحالة 3: InStr(" & intStart & ", """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 4: سلسلة فارغة strText = "" strSearch = "a" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 4: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 5: البحث عن كلمة كاملة strText = "Access VBA" strSearch = "VBA" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 5: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 6: البحث عن نفس الكلمة مكررة strText = "abcabcabc" strSearch = "abc" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 6: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 7: بدء البحث من منتصف النص intResult = InStr(5, strText, strSearch) Debug.Print "الحالة 7: InStr(5, """ & strText & """, """ & strSearch & """) = " & intResult ' الحالة 8: حساس لحالة الأحرف strText = "TestCase" strSearch = "case" intResult = InStr(1, strText, strSearch) Debug.Print "الحالة 8: InStr(1, """ & strText & """, """ & strSearch & """) = " & intResult & " (Compare = Binary افتراضي)" ' الحالة 9: تجاهل حالة الأحرف باستخدام vbTextCompare intResult = InStr(1, strText, strSearch, vbTextCompare) Debug.Print "الحالة 9: InStr(1, """ & strText & """, """ & strSearch & """, vbTextCompare) = " & intResult End Sub 2- ملخص سريع مباشر للحالات Public Sub TestInStrCases() Debug.Print "==================================================" Debug.Print "اختبار دالة InStr" Debug.Print "==================================================" Debug.Print "الحالة 1: InStr(1, ""Mohesam"", ""a"") = "; InStr(1, "Mohesam", "a") Debug.Print "الحالة 2: InStr(4, ""Mohesam"", ""a"") = "; InStr(4, "Mohesam", "a") Debug.Print "الحالة 3: InStr(1, ""Mohesam"", ""z"") = "; InStr(1, "Mohesam", "z") Debug.Print "الحالة 4: InStr(1, """", ""a"") = "; InStr(1, "", "a") Debug.Print "الحالة 5: InStr(1, ""Access VBA"", ""VBA"") = "; InStr(1, "Access VBA", "VBA") Debug.Print "الحالة 6: InStr(1, ""abcabcabc"", ""abc"") = "; InStr(1, "abcabcabc", "abc") Debug.Print "الحالة 7: InStr(5, ""abcabcabc"", ""abc"") = "; InStr(5, "abcabcabc", "abc") Debug.Print "الحالة 8: InStr(1, ""TestCase"", ""case"") = "; InStr(1, "TestCase", "case") Debug.Print "الحالة 9: InStr(1, ""TestCase"", ""case"", vbTextCompare) = "; InStr(1, "TestCase", "case", vbTextCompare) Debug.Print "==================================================" End Sub استخدام احترافي البحث عن رموز داخل نص دالة InStr يمكن توظيفها داخل دوال أكثر تقدما للبحث عن مجموعة من الرموز داخل نص معين Public Function GetSymbolsInText(ByVal strText As String, ByVal arrSymbols As Variant, ByRef arrFound() As String) As Boolean Dim varSymbol As Variant Dim colFound As Collection Set colFound = New Collection ' البحث عن كل رمز في النص For Each varSymbol In arrSymbols If InStr(strText, varSymbol) > 0 Then On Error Resume Next ' لتجنب تكرار العناصر في المجموعة colFound.Add varSymbol, CStr(varSymbol) On Error GoTo 0 End If Next ' تجهيز النتائج النهائية If colFound.Count > 0 Then ReDim arrFound(0 To colFound.Count - 1) Dim i As Long For i = 1 To colFound.Count arrFound(i - 1) = colFound(i) Next i GetSymbolsInText = True Else ReDim arrFound(-1 To -1) GetSymbolsInText = False End If End Function تجربة هذه الدالة Public Sub TestGetSymbolsInText() Dim arrSymbols As Variant Dim arrFound() As String Dim bolFound As Boolean Dim strTest As String arrSymbols = Array(",", ";", "|", "/", "\", "-", "_") strTest = "Mohesam-2025/Report_Aug" ' تنفيذ البحث bolFound = GetSymbolsInText(strTest, arrSymbols, arrFound) ' عرض النتائج If bolFound Then Debug.Print "تم العثور على الرموز التالية:" Dim i As Long For i = LBound(arrFound) To UBound(arrFound) Debug.Print arrFound(i) Next i Else Debug.Print "لا يوجد أي رمز" End If End Sub Sub TestTextCompareBehavior() Dim str1 As String Dim str2 As String str1 = "Access" str2 = "access" ' المقارنة الثنائية (تراعي حالة الأحرف) ' - لن تنجح Debug.Print "BinaryCompare: "; InStr(1, str1, str2, vbBinaryCompare) ' المقارنة النصية (تتجاهل حالة الأحرف) ' - ستنجح Debug.Print "TextCompare: "; InStr(1, str1, str2, vbTextCompare) End Sub الكود السابق يوضح الفرق بين نمطي المقارنة في دالة InStr vbBinaryCompare: يقارن مع مراعاة حالة الأحرف (case-sensitive) vbTextCompare: يقارن بدون مراعاة حالة الأحرف (case-insensitive) النتيجة 0 في المقارنة الثنائية تعني أن "access" لم يتم العثور عليها داخل "Access" بسبب اختلاف حالة الحروف أما في TextCompare فتم العثور على "access" في بداية "Access" لأن الحالة تم تجاهلها المعامل الرابع في InStr InStr(Start, String1, String2 , Compare) إذا لم يتم تحديد CompareMethod فإن Access يستخدم الإعداد الافتراضي (غالبا vbBinaryCompare) لذلك ينصح دائما بتحديد نوع المقارنة صراحة لتفادي النتائج غير المتوقعة خاصة عند تجاهل حالة الأحرف الخلاصــــــــــة InStr تعيد موضع أول ظهور لسلسلة داخل سلسلة أخرى (يبدأ من 1) تعيد 0 إذا لم يتم العثور على تطابق يمكن تخصيص نوع المقارنة باستخدام المعامل الرابع مفيدة لبناء دوال متقدمة لمعالجة النصوص والرموز لتجاهل حالة الأحرف استخدم vbTextCompare لا تعتمد على القيمة الافتراضية في Compare حددها دائما لتفادي النتائج غير المتوقعة هناك دالة مكملة لـ InStr تسمى InStrRev تقوم بالبحث من نهاية النص إلى بدايته قد تكون مفيدة جدا في بعض الحالات (مثل البحث عن آخر امتداد أو آخر فاصل) InStr(1, "file.name.txt", ".") ' 5 InStrRev("file.name.txt", ".") ' 10 بكده الشرح انتهى ولتحقيق اكبر قدر ممكن من الاستفادة وفيما يخص النقطة التالية: مفيدة لبناء دوال متقدمة لمعالجة النصوص والرموز دى فكرة كود داخل وحدة نمطية عامة فى الاعتماد على كل من InStr , InStrRev اتركها لكم للاستمتاع بها Option Compare Database Option Explicit Public Enum TextCase AsIs = 0 ' كما هو Lower = 1 ' أحرف صغيرة Upper = 2 ' أحرف كبيرة Proper = 3 ' أول حرف كبير End Enum ' تعريفات الأنواع Public Enum FilePartType FileNameWithExtension ' اسم الملف مع الامتداد FileNameOnly ' اسم الملف بدون الامتداد FileExtensionOnly ' الامتداد بدون النقطة FileExtensionWithDot ' الامتداد مع النقطة FullFolderPath ' المسار الكامل للمجلد ContainingFolderName ' اسم المجلد الحاوي فقط RootDrive ' الجذر (مثل C:\ أو اسم السيرفر) VersionOnly ' الإصدار فقط (مثل v1.2) DateOnly ' التاريخ فقط (مثل 2025-07-17) FullUNCPath ' المسار الكامل بصيغة UNC FileURL ' المسار بصيغة URL FileNameWithoutVersionOrDate ' اسم الملف بدون الإصدار أو التاريخ ServerAndShare ' السيرفر والمشاركة من مسار UNC End Enum ' كائنات على مستوى الوحدة لتحسين الأداء Private objFSO As Object Private objRegEx As Object ' الدالة الرئيسية لاستخراج أجزاء المسار Public Function ExtractFilePartPro( _ ByVal strPath As String, _ Optional ByVal enmPart As FilePartType = FileNameWithExtension, _ Optional ByVal enuTextCase As TextCase = AsIs, _ Optional ByRef strVersion As String = "", _ Optional ByRef strDate As String = "", _ Optional ByRef strError As String = "" _ ) As String Dim strResult As String Dim lngPos As Long Dim strFileName As String Dim strFolder As String Dim strExt As String Dim strParent As String Dim colMatches As Object Dim vMatch As Variant ' تهيئة رسالة الخطأ إلى فارغة strError = "" ' إنشاء الكائنات إذا لم تكن موجودة If objFSO Is Nothing Then Set objFSO = CreateObject("Scripting.FileSystemObject") If objRegEx Is Nothing Then Set objRegEx = CreateObject("VBScript.RegExp") With objRegEx .Global = True .IgnoreCase = True ' نمط محسن لدعم إصدارات مع أحرف وتواريخ بصيغ مختلفة .Pattern = "(v[\d\.]+[a-zA-Z-]*)|((?:19|20)\d{2}[-_/]?\d{2}[-_/]?\d{2}|\d{8})" End With End If On Error GoTo ErrHandler ' تنظيف المسار strPath = Trim(strPath) ' التحقق من المسار الفارغ If strPath = "" Then strError = "المسار فارغ" ExtractFilePartPro = "" Exit Function End If ' استخراج اسم الملف If objFSO.FileExists(strPath) Or InStrRev(strPath, "\") > 0 Then strFileName = Mid(strPath, InStrRev(strPath, "\") + 1) Else strFileName = strPath End If ' استخراج المسار الكامل للمجلد strFolder = Left(strPath, Len(strPath) - Len(strFileName)) ' استخراج الامتداد (يدعم الامتدادات المركبة مثل .tar.gz) If InStr(strFileName, ".") > 0 Then lngPos = InStrRev(strFileName, ".") strExt = Mid(strFileName, lngPos) If LCase(strExt) = ".gz" And InStrRev(strFileName, ".tar.gz") > 0 Then strExt = ".tar.gz" End If Else strExt = "" End If ' استخراج اسم المجلد الحاوي If Right(strFolder, 1) = "\" Then strFolder = Left(strFolder, Len(strFolder) - 1) If InStrRev(strFolder, "\") > 0 Then strParent = Mid(strFolder, InStrRev(strFolder, "\") + 1) Else strParent = "" End If ' استخراج الإصدار والتاريخ باستخدام RegExp If objRegEx.Test(strFileName) Then Set colMatches = objRegEx.Execute(strFileName) For Each vMatch In colMatches If Left(LCase(vMatch), 1) = "v" Then strVersion = vMatch Else strDate = vMatch End If Next End If ' اختيار الجزء المطلوب Select Case enmPart Case FileNameWithExtension strResult = strFileName Case FileNameOnly If strExt <> "" Then strResult = Left(strFileName, Len(strFileName) - Len(strExt)) Else strResult = strFileName End If Case FileExtensionOnly If strExt <> "" Then strResult = Mid(strExt, 2) Case FileExtensionWithDot strResult = strExt Case FullFolderPath strResult = strFolder Case ContainingFolderName strResult = strParent Case RootDrive If Left(strPath, 2) = "\\" Then strResult = Split(strPath, "\")(2) ' اسم السيرفر فقط Else strResult = Left(strPath, 3) End If Case VersionOnly strResult = strVersion Case DateOnly strResult = strDate Case FullUNCPath strResult = strPath Case FileURL If Left(strPath, 2) = "\\" Then strResult = "file://" & Replace(strPath, "\", "/") Else strResult = "file:///" & Replace(strPath, "\", "/") End If Case FileNameWithoutVersionOrDate strResult = objRegEx.Replace(strFileName, "") Case ServerAndShare If Left(strPath, 2) = "\\" Then Dim arrParts As Variant arrParts = Split(strPath, "\") If UBound(arrParts) >= 3 Then strResult = "\\" & arrParts(2) & "\" & arrParts(3) Else strResult = "" End If Else strResult = "" End If End Select ' تنسيق النص حسب الخيار المحدد Select Case enuTextCase Case Lower strResult = LCase(strResult) Case Upper strResult = UCase(strResult) Case Proper strResult = StrConv(strResult, vbProperCase) Case Else ' AsIs, لا تغيير End Select ExtractFilePartPro = strResult ExitHere: Set colMatches = Nothing Exit Function ErrHandler: strError = "خطأ: " & Err.Description ExtractFilePartPro = "" Resume ExitHere End Function ' روتين اختبار موسع Public Sub TestEnhanced() Dim strPath As String Dim strUNCPath As String Dim strResPath As String Dim strRes As String Dim strVer As String Dim strDat As String Dim strError As String ' تعيين مسارات الاختبار strPath = "C:\Test\MyDataBase\Officena.Accdb" strUNCPath = "\\Server\Myhiba\Officena.Accdb" strResPath = "C:\Test\MyFile_v3.4_2025-07-17.tar.gz" Debug.Print String(70, "=") Debug.Print "اختبارات استخراج أجزاء المسار" Debug.Print String(70, "=") ' اختبار الأجزاء الأساسية Debug.Print "اختبار الأجزاء الأساسية" Debug.Print String(70, "-") Debug.Print " الاسم مع الامتداد : " & ExtractFilePartPro(strPath, FileNameWithExtension) Debug.Print " الاسم فقط : " & ExtractFilePartPro(strPath, FileNameOnly) Debug.Print " الامتداد فقط : " & ExtractFilePartPro(strPath, FileExtensionOnly) Debug.Print " الامتداد مع النقطة : " & ExtractFilePartPro(strPath, FileExtensionWithDot) Debug.Print " اسم المجلد الحاوي : " & ExtractFilePartPro(strPath, ContainingFolderName) Debug.Print " المسار بدون اسم الملف : " & ExtractFilePartPro(strPath, FullFolderPath) Debug.Print " الجذر : " & ExtractFilePartPro(strPath, RootDrive) Debug.Print " المسار بصيغة UNC : " & ExtractFilePartPro(strUNCPath, FullUNCPath) Debug.Print " المسار بصيغة URL : " & ExtractFilePartPro(strUNCPath, FileURL) Debug.Print String(70, "-") ' اختبار استخراج الإصدار والتاريخ strRes = ExtractFilePartPro(strResPath, FileNameOnly, AsIs, strVer, strDat) Debug.Print "اختبار استخراج الإصدار والتاريخ" Debug.Print " الاسم : " & strRes Debug.Print " الإصدار : " & strVer Debug.Print " التاريخ : " & strDat ' اختبار الخيارات الجديدة Debug.Print " FileNameWithoutVersionOrDate: " & ExtractFilePartPro(strResPath, FileNameWithoutVersionOrDate) Debug.Print " ServerAndShare : " & ExtractFilePartPro(strUNCPath, ServerAndShare) ' اختبار معالجة الأخطاء strRes = ExtractFilePartPro("", FileNameWithExtension, AsIs, , , strError) Debug.Print " Empty path result : " & strRes & ", Error: " & strError strRes = ExtractFilePartPro("C:\Invalid\Path", FileNameWithExtension, AsIs, , , strError) Debug.Print " Invalid path result : " & strRes & ", Error: " & strError ' اختبار تنسيق الحروف Debug.Print " Upper case : " & ExtractFilePartPro(strPath, FileNameWithExtension, Upper) Debug.Print "======================================================" End Sub

يمكنك تجربة هذه المعادلة =SUMPRODUCT(--ISNUMBER(SEARCH(" " & TRIM(MID(SUBSTITUTE(A2," ",REPT(" ",100)), (ROW(INDIRECT("1:" & LEN(A2)-LEN(SUBSTITUTE(A2," ",""))+1))-1)*100+1, 100)) & " ", " " & $D$2 & " "))) بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته =TEXT((A4-INT(A4))*1000,"000")

وعليكم السلام ورحمة الله تعالى وبركاته data.xlsx

وعليكم السلام ورحمة الله وبركاته ملفك لا بحتوى على اي كود تم عمل كود لطلبك والكود مرن يطبع الى اخر صف قيه بيانات Sub PrPAGES() Dim printWS As Worksheet Dim lastRow As Long Dim printRange As Range Set printWS = ThisWorkbook.Sheets("S1") lastRow = printWS.Cells(printWS.Rows.Count, "A").End(xlUp).Row Set printRange = printWS.Range("A1:C" & lastRow) printWS.PageSetup.PrintArea = printRange.Address printWS.PrintOut End Sub 1نموذج.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته إليك الكود المطلوب لحفظ جميع الشهادات في ملف PDF داخل مجلد باسم برنامج الكنترول شيت في نفس مكان المصنف Option Explicit Private Const CopyRange As String = "A5:J49" Private Const sFolder As String = "برنامج الكنترول شيت" Private Const NamePDF As String = "شهادات الأول" Private Const CrWS As String = "شهادات الأول بالقديرات" Private Sub CommandButton1_Click() Dim tbl As Boolean: tbl = False On Error GoTo CleanExit Dim f As Worksheet: Set f = Sheets(CrWS) Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, tmp As Long, Rng As Range, OnRng As Range If IsEmpty(f.[J3].Value) Or Not IsNumeric(f.[J3].Value) Then _ MsgBox "يرجى تحديد رقم أول شهادة", vbExclamation, "تنبيه": Exit Sub début = f.[J3].Value: fin = f.[R3].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الشهادات من " & _ début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub SetApp False On Error Resume Next Set WS = Sheets("PDF") If Not WS Is Nothing Then Application.DisplayAlerts = False: WS.Delete: Application.DisplayAlerts = True Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = "PDF": WS.DisplayRightToLeft = True On Error GoTo 0 If WS Is Nothing Then: GoTo CleanExit tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile tmp = 1 Set OnRng = f.Range(CopyRange) For i = début To fin Step 5 f.[J3].Value = i: Set Rng = WS.Cells(tmp, 2) OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues: Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths For row = 1 To OnRng.Rows.Count WS.Rows(tmp + row - 1).RowHeight = OnRng.Rows(row).RowHeight - 1.5 Next If i + 5 <= fin Then WS.HPageBreaks.Add Before:=WS.Cells(tmp + OnRng.Rows.Count, 1) tmp = tmp + OnRng.Rows.Count + 1 Next With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .PaperSize = xlPaperA4: .CenterHorizontally = True: .CenterVertically = False End With sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False tbl = (Err.Number = 0) On Error GoTo 0 f.[J3].Value = 1 WS.Delete CleanExit: SetApp True MsgBox IIf(tbl, _ "تم تصدير جميع الشهادات بنجاح" & vbNewLine & _ "تم حفظ الملف باسم: " & NamePDF & vbNewLine & "في المجلد: " & sFolder, _ "حدث خطأ يرجى المحاولة مرة أخرى"), IIf(tbl, vbInformation, vbCritical), _ "PDF" & "تصدير الشهادات بصيغة" End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable End With End Sub وإليك في المرفقات شكل الملف PDF المستخرج بعد تنفيذ العملية لتأخذ فكرة واضحة عن النتيجة النهائية شهادات الأول والثانى- الصف الأول.rar شهادات الأول.pdf

السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل algammal جزاك الله كل خيرا على ثتاؤك ودعائك لي الاستاذ الفاضل Foksh تحية لك ولاخواننا في منتدى الاكسس بعد اذنكما ساطرح فكرة اخرى لطلب حبيبنا algammal حسب فهمى لطلبكم انكم تريدون البحث باسم الموظف او الرقم الوطني او من وظيفتهم طبيب كمثال اذا كان هذا الطلب فليس من الضرورى تجميع الاسماء في شيت واحد لان هذا سيزيد من حجم الملف وتكرار بيانات ليس لها ضرورة الفكرة كود يقوم بالبحث في شيت معاشات وشيت data باستخذام النطاق a5:m5 في شيت search ونتيجة البحث ينم وضعها في نفس الشيت بداية من A10 تم عمل قائمة بالاسماء بدل كنابنها ويتم تحديثها يدويا بواسطة زر وتتحدث تلقائيا عتد الانتهاء من البحث الملف المرفق يوضح الفكرة لكما ولكل اعضاء المنتدى وافر التقدير والاخترام طريقة اخرى للبحث.xlsb

تفضل جرب هدا Option Explicit Sub Convert_Arabic() Dim WS As Worksheet, OnRng As Range, ky As Range Dim i As Integer, j As Integer, NumArr As Variant, tmp As Variant Dim val As String, c As String, newVal As String, n As Boolean NumArr = Array(ChrW(1632), ChrW(1633), ChrW(1634), ChrW(1635), _ ChrW(1636), ChrW(1637), ChrW(1638), ChrW(1639), ChrW(1640), ChrW(1641)) tmp = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9") Set WS = Sheets("Sheet1") Set OnRng = WS.UsedRange Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.ErrorCheckingOptions.BackgroundChecking = False For Each ky In OnRng If Not IsEmpty(ky.Value) And Not ky.HasFormula Then val = Trim(ky.Text): newVal = "": n = False If val Like "*[" & Join(NumArr, "") & "]*" Then GoTo SubApp If Right(val, 1) = "%" Then n = True: val = Left(val, Len(val) - 1) For i = 1 To Len(val) c = Mid(val, i, 1) If c Like "[0-9]" Then newVal = newVal & NumArr(CInt(c)) Else newVal = newVal & c End If Next i If n Then newVal = newVal & "%" ky.NumberFormat = "@": ky.Value = newVal End If SubApp: Next ky Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub أو يمكنك التنقل بينها على الشكل التالي تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v2 .xlsb