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

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور 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

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

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

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاتة اهلا بكم اعضاء المنتدى الكرام اعتذر جدا للغياب الطويل عن المنتدى ولكن اشتقت اليكم فقولت ارجع بكود ممكن يفيد البعض فى عملة يعتبر البحث عن البيانات من الامور التى يبحث عنها كل مستخدمى الاكسل حيث انها تسهل عليهم اعمالهم وتحليل البيانات لديهم ولكن اذا كان لديك بيانات كثيرة جدا فى شيت الاكسل فالامر هنا يكون شاق ومرهق ومن هنا قررنا انشاء كود بحث من خلال اليوزرفورم يقوم بالبحث عن البيانات وتلوين واظهار نتائج البحث يتم وضع الكود فى حدث التكست بوكس 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 وما قبلها . :: ولا تنسونا من صالح دعواتكم الطيبة 🙂 🌹🌷 ::

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكنها بالحديثة و بطريقة فوكشية ▫▪◽◾◻◼. الكثير من المواضيع التي تحدثت عن كيفية رفع ملفات المستخدم على جوجل درايف أو غيره من المواقع التي تقدم مساحات سحابية متعددة الخدمات لمستخدميها .. اليوم وبتوفيق من الله ، تم إنشاء هذه الأداة للتعامل مع جوجل درايف 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

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

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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) بالإشارة الى الموضوع الذي أعلنت عنه سابقاً في هذا الرابط هنا ، اسمحوا لي بأن أطرح هذه الفكرة الجديدة والتي تم تجربتها مراراً وتكراراً إلى أن خرجت بهذه النتيجة فيما يتعلق بموضوع التحديث الهوائي أو 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 ] * عذراً إن كانت طريقتي في العمل مزعجة أو غريبة نوعاً ما ، لكن هو طبعي 😅 . فماذا أفعل ؟؟!!

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكن بطريقة ونكهة مختلفتين ▫▪◽◾◻◼. "أداة مستورد السجلات الذكي من 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 💢 🔴 وجب علي التنويه إلى نقطة مهمة وهي :- قد يأتي أحد الأخوة لاختيار ملف يحتوي على ترويسة أو صورة في أول ملف الإكسل الذي اختاره ، ويقول لي أنه لم يظهر لي أي أسماء للأعمدة التي تحدثت عنها ( وأن الأداة لم تخدمه بشكل أو بآخر ) وهنا وأعتذر منه مسبقاً بأن هذا الخلل ليس في الأداة وإنما في ملف الآكسل . فأنا لا استطيع أن أجبرك على تصميم معين لملف الآكسل الذيتريد الإستيراد منه ، ولكني بنفس الوقت أقترح عليك أن تزيل هذه الإضافات والمعوقات كي تستفيد من الأداة بشكل ممتاز .

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

وعليكم السلام ورحمة الله نعالى وبركاته دالة 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

السلام عليكم ورحمة الله تعالى وبركاته يواجه الكثير من المصممين مشكلة اختلاف اللغة او بمعنى ادق يريد الكثير ان تكون لغة الازرار والتطبيق والرسائل موحدة وهذا ما لا يحدث عندما تكون نسخة الويندوز مثلا انجليزية والتطبيق بمصمم باللغة العربية او حتى يكون التعبير اكثر دقه عندما تختلف لغة واجهة المستخدم فى الويندوز عن اللغة التى يريد المصمم ان تظهر بها كل كبيرة وصغيرة قى التطبيق بما فيها ازرار الرسائل مثال لكى تكون الصورة اكثر وضوحا الرسالة بالعربى وهنا يريد المصمم ان تكون لغة الازرار كذلك بالعربى ولكن لغة واجهة الاستخدام انجليزية وعنوان الزر يظهر تبعا للغة الويندوز تم التغلب عليها مسبقا باستخدام دوال الـ API ولست بصدد الحديث عنها لان بها قيد وهو - شرط لان يتم تغيير اسماء الازرار فى صندوق الرسائل بالاسماء التى يرغب بها المستخدم ان تكوت الخصيصة pop up للنموج = No وهذا فيه تقييد للمصمم وخاصة ان كان يستخدم هذه الخصيصة بالشكل التالى pop up للنموج = Yes وكان الحل البديل هو عمل نموذج للرسائل بدلا من استخدام صندوق الرسائل واعتقد تم عمل ذلك مسبقا فى المنتدى ولكن انا الان اقدمه بافضل اسلوب احترافى واكثر مرونه. لعمل ذلك اولا قم بتصميم نموذج للرسائل واعطه الاسم : frmCustomMessageBox وان اردت تغيير الاسم قم بالتسمية التى تناسبك مع مراعاة تغيير الاسم كذلك فى الكود الذى سوف اقدمه بعد قليل والمستخدم فى الوحدة النمطية العامة الان افتح نموذج الرسائل "frmCustomMessageBox" فى وضع التصميم اضف العناصر التاليه عدد 5 عنصر "Buttons" أزرار أوامر على ان تكون الاسماء للازرار كالتالى : Button0 , Button1 , Button2 , Button3 , Button4 عدد 1 عنصر "Labels" عنوان : على ان يكون اسمه كالتالى : MessageLabel عدد 1 عنصر "Image" صورة : على ان يكون اسمه كالتالى : IconImage والان اضف وحدة نمطية عامة واعطها مثلا الاسم : basCustomMessageBox اضف اليها الكود التالى ' متغير لتخزين رقم الزر الذي تم الضغط عليه في نموذج الرسائل المخصص. Private intPressedButton As Integer ' دالة لعرض صندوق رسائل مخصص ' Parameters: ' - arrMessageLines: مصفوفة تحتوي على أسطر الرسالة. ' - strTitle: عنوان صندوق الرسائل. ' - strButtons: قائمة أزرار مفصولة بفواصل. ' - arrTooltips: مصفوفة تحتوي على تلميحات للأزرار (اختياري). ' - strIconPath: مسار الأيقونة (اختياري). ' Returns: ' - رقم الزر الذي تم الضغط عليه (بدءًا من 0 إلى 4)، أو -1 في حالة حدوث خطأ. Function MsgBx(arrMessageLines As Variant, strTitle As String, strButtons As String, Optional arrTooltips As Variant = Null, Optional strIconPath As String = "") As Integer On Error GoTo ErrorHandler Dim frmCustomMsgBox As Form Dim ctrlCurrent As Control Dim strButtonCaption As Variant Dim intButtonIndex As Integer Dim arrButtonCaptions As Variant Dim strMessage As String Dim strLine As Variant Dim strFormName As String strFormName = "frmCustomMessageBox" ' بناء الرسالة من الأسطر الممررة strMessage = "" For Each strLine In arrMessageLines If strMessage <> "" Then strMessage = strMessage & vbCrLf ' إضافة سطر جديد بين الأسطر End If strMessage = strMessage & strLine Next strLine ' التحقق إذا كان النموذج مفتوحًا If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0 Then ' إذا كان النموذج مفتوحًا، فقط استعد المرجع إليه Set frmCustomMsgBox = Forms(strFormName) Else ' إذا لم يكن مفتوحًا، افتحه DoCmd.OpenForm strFormName, acNormal, , , , acHidden Set frmCustomMsgBox = Forms(strFormName) End If ' إعداد خصائص النموذج With frmCustomMsgBox .Caption = strTitle .Controls("MessageLabel").Caption = strMessage ' إظهار التسمية فقط إذا كان هناك نص .Controls("MessageLabel").Visible = (strMessage <> "") ' إضافة الأزرار الجديدة بناءً على strButtons intButtonIndex = 0 arrButtonCaptions = Split(strButtons, ",") For Each strButtonCaption In arrButtonCaptions With .Controls("Button" & intButtonIndex) .Caption = strButtonCaption .Visible = True .OnClick = "=PressedButton(" & intButtonIndex & ")" ' تعيين التلميحات للأزرار إذا تم تمريرها If Not IsNull(arrTooltips) And IsArray(arrTooltips) Then If intButtonIndex <= UBound(arrTooltips) Then .ControlTipText = arrTooltips(intButtonIndex) End If End If End With intButtonIndex = intButtonIndex + 1 Next strButtonCaption ' تعيين الأيقونة إذا كان مسارها موجودًا If strIconPath <> "" Then If Dir(strIconPath) <> "" Then ' إذا كانت الأيقونة موجودة، قم بتعيينها On Error Resume Next ' تجاهل الخطأ إذا حدث .Controls("IconImage").Picture = strIconPath If Err.Number <> 0 Then ' إذا حدث خطأ، أخفي عنصر التحكم .Controls("IconImage").Visible = False Err.Clear Else .Controls("IconImage").Visible = True End If On Error GoTo ErrorHandler ' العودة إلى إدارة الأخطاء العادية Else ' إذا لم تكن الأيقونة موجودة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If Else ' إذا لم يتم تمرير أيقونة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If End With ' إظهار النموذج كمودال DoCmd.OpenForm strFormName, acNormal intPressedButton = -1 ' انتظار المستخدم لتحديد زر Do DoEvents Loop Until intPressedButton > -1 ' إرجاع القيمة وإغلاق النموذج DoCmd.Close acForm, strFormName, acSaveNo MsgBx = intPressedButton Exit Function ErrorHandler: ' إرجاع قيمة تشير إلى فشل العملية MsgBx = -1 MsgBox "حدث خطأ: " & Err.Number & " | " & Err.Description Debug.Print "حدث خطأ: " & Err.Number & " | " & Err.Description Exit Function End Function Function PressedButton(intButtonIndex As Integer) ' تسجيل الرقم الخاص بالزر المضغوط intPressedButton = intButtonIndex End Function والان طريقة الاستدعاء من اى زر امر لهواة الاختصار فى الاكواد من اى نموذج تكون كالتالى ' تعريف متغير لتخزين نتيجة اختيار المستخدم من النافذة المنبثقة Dim Result As Integer Result = MsgBx(Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟"), "تحذير", "نعم,لا", Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء"), "Full-Path\error.png") If Result = 0 Then MsgBox "تم اختيار موافق" ElseIf Result = 1 Then MsgBox "تم اختيار إلغاء" End If ولكن الطريقة الأمثل لسهولة التعديل والاضافة والصيانة فى المستقبل يكون الاستدعاء بالشكل التالى ' تعريف المتغيرات المستخدمة Dim MessageLines As Variant ' تخزين سطور الرسالة (نص رئيسي وفرعي) Dim TitleText As String ' عنوان النافذة المنبثقة Dim ButtonsText As String ' نص الأزرار (مفصولة بفواصل) Dim Result As Integer ' نتيجة اختيار المستخدم Dim IconPath As String ' مسار ملف أيقونة التحذير Dim Tooltips As Variant ' تلميحات توضيحية عند التمرير على الأزرار ' تعيين مسار ملف الأيقونة التحذيرية (يجب التأكد من صحة المسار) IconPath = "Full-Path\error.png" ' تهيئة محتوى الرسالة: MessageLines = Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟") TitleText = "تحذير" ' عنوان النافذة المنبثقة ButtonsText = "نعم,لا" ' خيارات الأزرار (الزر الأول: نعم، الزر الثاني: لا) ' تعيين التلميحات التوضيحية عند تمرير الماوس على الأزرار: ' تلميح للزر الأول (نعم) ' تلميح للزر الثاني (لا) Tooltips = Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء") ' استدعاء الدالة المخصصة لعرض الرسالة: ' محتوى الرسالة -العنوان - اسماء الأزرار - التلميحات - مسار الأيقونة Result = MsgBx(MessageLines, TitleText, ButtonsText, Tooltips, IconPath) ' معالجة النتيجة المرجعة من الدالة: If Result = -1 Then ' حالة الخطأ (-1 تعني فشل في عرض الرسالة) MsgBox "حدث خطأ أثناء عرض الرسالة." ElseIf Result = 0 Then ' الزر الأول (نعم) تم اختياره MsgBox "تم اختيار نعم" ElseIf Result = 1 Then ' الزر الثاني (لا) تم اختياره MsgBox "تم اختيار لا" End If لتكون النتيجة كما بالشكل التالى من النموج بدلا من صندوق الرسائل التقليدى طبعا يمكن تغيير اسماء الازرار عند الاستدعاء من السطر : ButtonsText = "نعم, لا" ليكون مثلا ButtonsText = "موافق , الغاء" وطبعا تغير السطر : MsgBox "تم اختيار نعم" باضافة الكود الذى تريده عند الضغط على الزر انا فقط كتبت الرسالة فى كود الاستدعاء لتوضيح انه سوف يتم تنفيذ الامر ملحوظة : استخدام : Tooltips وهو التلميح عندما يحوم الماوس فوق الازرار فى النموذج اختيارى ممكن عدم استخدامه كذلك استخدام : IconPath وهو مسار لصورة ايقونة تدل على الرسالة اختيارى ممكن عدم استخدامه ولكن طبعا انا كتبت الكود بحيث يوفر اكبر قدر ممكن من المرونه فى تناول او عدم تناول هذه الخصائص لمن يريد تغيير الايقونات مع كل رسالة او تغيير عدد او اسماء الازرار مع كل رسالة وكذلك التلميحات للازرار المستخدمه ملاحطة هامة جدا جدا جدا : لا تنسي اخفاء كل ازرار الاوامر الخمسة فى النموذج الكود سوف يقوم بإعادة اظهار الازرار حسب الاستدعاء تحياتى الحارة CustomMessageBox.zip

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

السلام عليكم 🙂 رجاء الرجوع الى النسخة الاولى من هذا الموضوع لفهم تفاصيل الكود . عرضت عليكم جميع التفاصيل في عمل حدث الـ 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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كنت قد بحثت في المنتدى 🔍 (هنا) عن برامج لعرض مواقيت الصلاة ، وقد وجدت الكثير من المواضيع الجميلة والأفكار النيرة في المنتدى لأساتذة وأخوة بذلوا جهداً لا يوصف في مشاركاتهم بهذا الموضوع ، وإلى حد ما أكثرهم قرباً لضبط الأوقات كانت هذه المشاركة . اليوم الفكرة مختلفة قليلاً في هذا المشروع المتواضع والذي لا يحتوي تعقيدات يصعب قراءتها أو التعامل معها في الأكواد . حيث اعتمدت وتوجهت إلى البساطة من حيث عند النقل والدمج ( إلى / في ) أي مشروع . الآن شرح بسيط لبعض تفاصيل المشروع التي سيتم الإعتماد عليها :- سي سيتم الإعتماد على خطوط الطول والعرض بعد إجراء بعض التعديلات على طريقة احتساب الأوقات . وقد تمت المقارنة مع موقع ( مواقيت الصلاة ) للوصول إلى أقل فارق - إن وُجِد - في المواقيت . سيتم الإعتماد على تقويم أم القرى في أحدى مشاركات أستاذنا @ابوخليل . سيتم اعتماد إظهار الوقت المتبقي لكل موعد صلاة في الشاشة الرئيسية أو المصغرة ( ستضاف لاحقاً ) . سيتم منح الحرية للمستخدم بنوع التذكير لوقت الصلاة ( إشعار برسالة تنبيه داخل البرنامج ، إشعار فوق شريط Taskbar ) . سيتم أيضاً منح الحرية للمستخدم باختيار صوت التنبيه ( أذان كامل ، تكبير ، .... إلخ ) . المزيد من الأمور ستأتي لاحقاً تباعاً في تطويرات وتحديثات جديدة إن شاء الله . صورة لواجهة البرنامج حالياً ، والذي أسميته في الوقت الحالي " صلوات " 🤗 ، ما لم يتم اختيار اسم آخر تم التعديل بتاريخ 01/06/2024 وذلك لاضافة المرفق النهائى Salatak.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 . جعفر

Ferry Login v1- free.rar

السلام عليكم ورحمة الله وبركاته اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد) تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة اختيار متعدد أو فردي اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى Option Compare Database Option Explicit ' Global variables for file selection and allowed extensions Public IsFolderMode As Boolean ' Toggle folder selection mode Public AllowedExtensions As Collection ' Store allowed file extensions ' Enumeration for File Dialog Types Public Enum FileDialogType FilePicker = 1 ' Dialog for selecting files FolderPicker = 4 ' Dialog for selecting folders End Enum ' Enumeration for processing file path Public Enum FileProcessingMode FullPath = 1 ' Return the full file path NameWithoutExtension = 2 ' Return the file name without extension NameWithExtension = 3 ' Return the file name with extension End Enum ' Enumeration for file categories Public Enum FileCategory AccessFiles = 1 ' Access Database files (accdb, mdb, accda, etc.) ExcelFiles = 2 ' Excel files (xlsx, xls, xlsm, etc.) WordFiles = 3 ' Word files (docx, doc, docm, etc.) ImageFiles = 4 ' Images category (jpg, png, gif, bmp, tiff, etc.) AudioFiles = 5 ' Audio category (mp3, wav, ogg, flac, etc.) VideoFiles = 6 ' Video category (mp4, avi, mov, mkv, etc.) AcrobatFiles = 7 ' Acrobat PDF files (pdf) TextFiles = 8 ' Text files (txt, csv, log, md, etc.) PowerPointFiles = 9 ' PowerPoint files (pptx, ppt, pptm, etc.) CompressedFiles = 10 ' Compressed files (zip, rar, 7z, tar, gz, etc.) CodeFiles = 11 ' Code files (html, css, js, php, py, java, etc.) ExecutableFiles = 12 ' Executable files (exe, bat, cmd, apk, etc.) AllFiles = 13 ' All file types (*.*) End Enum ' Initialize the allowed extensions for a specific file category Sub InitializeExtensions(ByVal Category As FileCategory) Set AllowedExtensions = New Collection Select Case Category ' Access Database files Case AccessFiles AddExtensions Array("accda", "accdb", "accde", "accdr", "accdt", "accdw", "mda", "mdb", "mde", "mdf", "mdw") ' Excel files Case ExcelFiles AddExtensions Array("xlsx", "xls", "xlsm", "xlsb", "xltx", "xltm") ' Word files Case WordFiles AddExtensions Array("docx", "doc", "docm", "dotx", "dotm", "rtf", "odt") ' Image files Case ImageFiles AddExtensions Array("jpg", "jpeg", "png", "gif", "bmp", "tiff", "tif", "ico", "webp", "heif", "heic") ' Audio files Case AudioFiles AddExtensions Array("mp3", "wav", "ogg", "flac", "aac", "m4a", "wma", "alac", "opus", "aiff") ' Video files Case VideoFiles AddExtensions Array("mp4", "avi", "mov", "mkv", "flv", "wmv", "webm", "mpeg", "mpg", "3gp", "ts") ' Acrobat PDF files Case AcrobatFiles AllowedExtensions.Add "pdf" ' Text files Case TextFiles AddExtensions Array("txt", "csv", "log", "md", "rtf") ' PowerPoint files Case PowerPointFiles AddExtensions Array("pptx", "ppt", "ppsx", "pps", "pptm", "potx", "potm") ' Compressed files (Archives) Case CompressedFiles AddExtensions Array("zip", "rar", "7z", "tar", "gz", "tar.gz", "tgz", "xz", "bz2") ' Code files Case CodeFiles AddExtensions Array("html", "css", "js", "php", "py", "java", "cpp", "c", "rb", "swift", "go", "ts") ' Executable files Case ExecutableFiles AddExtensions Array("exe", "bat", "cmd", "msi", "apk", "app", "dmg", "jar") ' All file types Case AllFiles AllowedExtensions.Add "*.*" Case Else MsgBox "Invalid category provided!", vbCritical End Select End Sub ' Add an array of extensions to the AllowedExtensions collection Private Sub AddExtensions(ByVal ExtensionsArray As Variant) Dim Extension As Variant For Each Extension In ExtensionsArray AllowedExtensions.Add Extension Next Extension End Sub ' Display a file or folder dialog and return the selected files Function GetFiles(Optional ByVal Extensions As Collection = Nothing, Optional ByVal SingleFile As Boolean = False) As Collection Dim FileDialog As Object Dim FolderDialog As Object Dim SelectedFiles As New Collection Dim FolderPath As String Dim FilterString As String On Error GoTo ErrorHandler ' Build the file dialog filter FilterString = BuildFilterString(Extensions) If Not IsFolderMode Then ' File selection dialog Set FileDialog = Application.FileDialog(FileDialogType.FilePicker) With FileDialog .Title = "Select File(s)" .AllowMultiSelect = Not SingleFile .Filters.Clear .Filters.Add "Allowed Files", FilterString If .Show = -1 Then AddSelectedFilesToCollection FileDialog, SingleFile, SelectedFiles End If End With Else ' Folder selection dialog Set FolderDialog = Application.FileDialog(FileDialogType.FolderPicker) With FolderDialog .Title = "Select Folder" If .Show = -1 Then FolderPath = .SelectedItems(1) SelectedFiles.Add FolderPath End If End With End If ' Return the selected files or folder If SelectedFiles.Count > 0 Then Set GetFiles = SelectedFiles Else MsgBox "No files or folder selected.", vbExclamation Set GetFiles = Nothing Exit Function End If CleanUp: Set FileDialog = Nothing Set FolderDialog = Nothing Exit Function ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical Resume CleanUp End Function ' Build the file dialog filter string Private Function BuildFilterString(ByVal Extensions As Collection) As String Dim Filter As String Dim Extension As Variant If Not Extensions Is Nothing Then For Each Extension In Extensions Filter = Filter & "*." & Extension & ";" Next Extension If Len(Filter) > 0 Then Filter = Left(Filter, Len(Filter) - 1) Else Filter = "*.*" End If BuildFilterString = Filter End Function ' Add selected files to the collection Private Sub AddSelectedFilesToCollection(ByVal Dialog As Object, ByVal SingleFile As Boolean, ByRef FilesCollection As Collection) Dim Index As Long If SingleFile Then FilesCollection.Add Dialog.SelectedItems(1) Else For Index = 1 To Dialog.SelectedItems.Count FilesCollection.Add Dialog.SelectedItems(Index) Next Index End If End Sub ' Function to check if the file extension is allowed Function IsAllowedExtension(ByVal strExt As String, ByVal colExtensions As Collection) As Boolean Dim varExt As Variant If colExtensions Is Nothing Or colExtensions.Count = 0 Then IsAllowedExtension = True ' Allow all extensions if colExtensions is Nothing or empty Exit Function End If For Each varExt In colExtensions If LCase(strExt) = LCase(varExt) Then IsAllowedExtension = True Exit Function End If Next varExt IsAllowedExtension = False End Function ' Subroutine to select a folder and retrieve all files based on allowed extensions Sub SelectFilesInFolder(ByVal FileCategoryType As FileCategory) Dim SelectedFiles As Collection ' Collection to hold the selected files Dim FolderPath As String ' Folder path selected by the user Dim CurrentFileName As String ' Current file name during folder iteration Dim FileExtension As String ' File extension for the current file Dim FilteredFiles As New Collection ' Collection to hold filtered files Dim FileItem As Variant ' Variable to iterate through filtered files On Error GoTo ErrorHandler ' Handle errors if they occur ' Enable folder selection mode IsFolderMode = True ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a folder Set SelectedFiles = GetFiles(Nothing, False) ' Pass Nothing for extensions as folder mode doesn't filter by type ' Check if a folder was selected If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Get the first (and only) selected folder path FolderPath = SelectedFiles(1) ' Start iterating through all files in the selected folder CurrentFileName = Dir(FolderPath & "\*.*") ' Retrieve the first file in the folder Do While CurrentFileName <> "" ' Extract file extension and convert it to lowercase FileExtension = LCase(Split(CurrentFileName, ".")(UBound(Split(CurrentFileName, ".")))) ' Check if the file extension is allowed and add it to the filtered collection If IsAllowedExtension(FileExtension, AllowedExtensions) Then FilteredFiles.Add FolderPath & "\" & CurrentFileName End If ' Retrieve the next file in the folder CurrentFileName = Dir Loop ' If there are filtered files, display their paths If FilteredFiles.Count > 0 Then For Each FileItem In FilteredFiles Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files found matching the allowed extensions.", vbExclamation End If Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub Sub SelectFolderPath() On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim colFiles As Collection IsFolderMode = True ' Set folder mode to true for folder selection Set colFiles = GetFiles(Nothing, False) ' Pass Nothing for colExtensions as we are dealing with folders On Error Resume Next If Not colFiles Is Nothing And colFiles.Count > 0 Then PrintFilePaths colFiles Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate single file selection with specific extensions Sub SelectSingleFile(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a single file with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, True) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate multiple file selection with specific extensions Sub SelectMultipleFiles(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select multiple files with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to print file paths from a collection Sub PrintFilePaths(ByVal Files As Collection) ' Variable to iterate through filtered files Dim FileItem As Variant ' Check if the collection is valid and contains files If Not Files Is Nothing And Files.Count > 0 Then For Each FileItem In Files Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files were selected or matched the allowed extensions.", vbExclamation End If End Sub ' Subroutine to process file paths, extract name, name without extension, and extension Sub ProcessFilePaths(ByVal colFiles As Collection) ' Variable to iterate through the collection Dim varFilePath As Variant ' Variable to hold the current file path as a string Dim strFilePath As String ' Variables to hold extracted components of the file path Dim fileName As String Dim fileNameWithoutExt As String Dim fileExt As String ' Check if the collection is not empty or Nothing If Not colFiles Is Nothing Then ' Loop through each file path in the collection For Each varFilePath In colFiles ' Assign the current file path to a string variable strFilePath = varFilePath ' Extract the file name from the full path fileName = GetFileNameFromPath(strFilePath) ' Extract the file name without the extension fileNameWithoutExt = GetFileNameWithoutExtension(strFilePath) ' Extract the file extension (including the dot) fileExt = GetFileExtension(strFilePath) ' ' Print the extracted information to the Immediate Window (Ctrl+G in VBA Editor) ' Debug.Print "Full Path: " & varFilePath ' Debug.Print "File Name: " & fileName ' Debug.Print "File Name Without Extension: " & fileNameWithoutExt ' Debug.Print "File Extension: " & fileExt ' Debug.Print "------------------------------" Next varFilePath Else ' Show a message box if the collection is empty or Nothing MsgBox "No files found.", vbInformation End If End Sub ' Function to extract the file name (including extension) from a full file path Function GetFileNameFromPath(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameFromPath = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim pos As Long pos = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If pos = 0 Then pos = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract and return the file name If pos > 0 Then GetFileNameFromPath = Mid(FilePath, pos + 1) ' Return everything after the last separator Else GetFileNameFromPath = FilePath ' If no separator is found, return the full path End If End Function ' Function to extract the file name without its extension from a full file path Function GetFileNameWithoutExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameWithoutExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim posBackslash As Integer posBackslash = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If posBackslash = 0 Then posBackslash = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract the file name (with extension) Dim fileName As String If posBackslash > 0 Then fileName = Mid(FilePath, posBackslash + 1) ' Extract the file name Else fileName = FilePath ' If no separator, the full path is considered the file name End If ' Search for the last dot in the file name to identify the extension Dim posDot As Integer posDot = InStrRev(fileName, ".") ' Find the position of the last dot ' Remove the extension if a dot is found If posDot > 0 Then GetFileNameWithoutExtension = Left(fileName, posDot - 1) ' Return the name without the extension Else GetFileNameWithoutExtension = fileName ' If no dot, return the full file name End If End Function ' Function to extract the file extension (including the dot) from a full file path Function GetFileExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last dot in the file path Dim posDot As Integer posDot = InStrRev(FilePath, ".") ' Find the position of the last dot ' Extract and return the file extension If posDot > 0 Then GetFileExtension = Mid(FilePath, posDot) ' Return everything after (and including) the last dot Else GetFileExtension = "" ' If no dot is found, return an empty string End If End Function ' Subroutine to save file paths or details into a database table ' Parameters: ' - SelectedFiles: Collection of selected file paths. ' - TableName: Name of the database table where data will be saved. ' - FieldName: Name of the field in the table to store the file information. ' - ProcessingMode: Determines how the file paths will be processed before saving. Default is FullPath. Sub SaveFileDetailsToTable(SelectedFiles As Collection, TableName As String, FieldName As String, Optional ByVal ProcessingMode As FileProcessingMode = FullPath) On Error GoTo ErrorHandler ' Handle errors if they occur Dim varFilePath As Variant Dim ProcessedValue As String ' Check if the SelectedFiles collection is valid and contains files If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Loop through each file in the collection For Each varFilePath In SelectedFiles ' Determine how the file path should be processed based on ProcessingMode Select Case ProcessingMode Case FullPath ' Use the full file path as the value to save ProcessedValue = CStr(varFilePath) Case NameWithoutExtension ' Extract and use the file name without its extension ProcessedValue = GetFileNameWithoutExtension(CStr(varFilePath)) Case NameWithExtension ' Extract and use the file name including its extension ProcessedValue = GetFileNameFromPath(CStr(varFilePath)) Case Else ' Default to using the full file path ProcessedValue = CStr(varFilePath) End Select ' Construct the SQL statement to insert the processed value into the specified table and field Dim SQL As String SQL = "INSERT INTO [" & TableName & "] ([" & FieldName & "]) VALUES ('" & Replace(ProcessedValue, "'", "''") & "')" ' Execute the SQL statement to save the data into the database CurrentDb.Execute SQL, dbFailOnError Next varFilePath Else ' Display a message if no files were found in the collection MsgBox "No files found.", vbInformation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Test method to demonstrate saving file details to a table ' This subroutine selects files and saves their names without extensions into a database table Sub TestSaveResults() Dim SelectedFiles As Collection ' Set mode to file selection mode IsFolderMode = False ' Initialize allowed extensions for the specific category (e.g., images in this case) InitializeExtensions ImageFiles ' Prompt the user to select files based on the allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Save the selected file names (without extensions) into the table "tblMedia" in the "fieldName" column SaveFileDetailsToTable SelectedFiles, "tblMedia", "fieldName", NameWithoutExtension End Sub ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

السلام عليكم تم التعديل

مشاركة مع الإخوة الأعزاء 🙂 هذه طريقتي في تضمين الخطوط في البرنامج .. 1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات : 2 - في الموديول كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات : 3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 4- وبعدها ستجد أن الخطوط تعمل لديك بشكل جيد بدون مشاكل إن شاء الله 🙂 للتطبيق على برنامجك أنقل جميع العناصر لبرنامجك وغير الخطوط في الجدول . الملف : Add Fonts.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 101" الحالات التى يمكن الحصول عليها من معالجة النص السابق هى ازالة المسافات فقط وتنظيف النص مع الابقاء على الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم 101 ازالة المسافات وتنظيف النص مع الابقاء على الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم 101 ازالة المسافات وتنظيف النص مع ازالة الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم ازالة المسافات فقط وتنظيف النص مع ازالة الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم الكود ' Function: ArabicTextSanitizer ' Purpose: Sanitizes Arabic text by removing non-Arabic characters, optionally normalizing the text, ' removing diacritics (harakat), and optionally removing numeric characters or spaces. ' Parameters: ' inputText (String): The Arabic text to be sanitized. It can contain Arabic characters, non-Arabic characters, ' diacritics, and numeric values. ' normalize (Boolean): Optional. If True, the text will be normalized by replacing specific Arabic characters ' with their standardized equivalents (default is True). ' RemoveNumbers (Boolean): Optional. If True, numeric characters (0-9) will be removed from the text (default is True). ' removeSpaces (Boolean): Optional. If True, all spaces in the text will be removed (default is False). ' Returns: ' String: The sanitized Arabic text with optional normalization, removal of numbers, and spaces. ' ' Example Use Cases: ' 1. Remove spaces only and clean the text while keeping numbers without normalization: ' ' Removes spaces from the text while keeping numbers and without normalizing the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, False, True) ' ' 2. Remove spaces and clean the text while keeping numbers and normalizing: ' ' Normalizes the text and removes spaces, while keeping numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, False, True) ' ' 3. Remove spaces and clean the text while removing numbers and normalizing: ' ' Normalizes the text, removes spaces, and removes numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, True, True) ' ' 4. Remove spaces only and clean the text while removing numbers without normalization: ' ' Removes spaces and numbers, but does not normalize the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, True, True) ' Public Function ArabicTextSanitizer(inputText As String, Optional normalize As Boolean = True, Optional RemoveNumbers As Boolean = True) As String On Error GoTo ErrorHandler ' Ensure the input is valid (non-empty and not null) If Nz(inputText, "") = "" Then ArabicTextSanitizer = "" Exit Function End If ' Initialize the sanitizedText with the trimmed input Dim sanitizedText As String sanitizedText = Trim(inputText) ' Step 1: Normalize the text if requested If normalize Then ' Define character replacement pairs for normalization Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) ' Apply replacements for character normalization Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next ' Step 2: Remove diacritics (harakat) from the text Dim diacritics As String diacritics = ChrW(1600) & ChrW(1611) & ChrW(1612) & ChrW(1613) & ChrW(1614) & ChrW(1615) & ChrW(1616) & ChrW(1617) & ChrW(1618) Dim i As Integer For i = 1 To Len(diacritics) sanitizedText = Replace(sanitizedText, Mid(diacritics, i, 1), "") Next End If ' Step 3: Retain only Arabic characters, spaces, and optionally numbers Dim tempChars() As String Dim charIndex As Long Dim intChar As Integer Dim finalResultText As String ' Iterate through each character in the sanitized text For i = 1 To Len(sanitizedText) intChar = AscW(Mid(sanitizedText, i, 1)) ' Check for Arabic characters (range for Arabic characters and spaces) If intChar = 32 Or _ (intChar >= 1569 And intChar <= 1594) Or _ (intChar >= 1601 And intChar <= 1610) Or _ (intChar >= 1648 And intChar <= 1649) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 ' Optionally, check for numbers if RemoveNumbers is False ElseIf Not RemoveNumbers And (intChar >= 48 And intChar <= 57) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 End If Next ' Step 4: Join the valid characters into a final result text finalResultText = Join(tempChars, "") ' Step 5: Remove extra spaces (multiple consecutive spaces replaced with a single space) finalResultText = Replace(finalResultText, " ", " ") ' Improved space replacement Do While InStr(finalResultText, " ") > 0 finalResultText = Replace(finalResultText, " ", " ") Loop ' Step 6: Remove special characters (if needed) finalResultText = Replace(finalResultText, "*", "") finalResultText = Replace(finalResultText, "#", "") finalResultText = Replace(finalResultText, "@", "") finalResultText = Replace(finalResultText, ",", "") ' Return the sanitized text If Len(Trim(Nz(finalResultText, ""))) = 0 Then ArabicTextSanitizer = vbNullString Else ArabicTextSanitizer = finalResultText End If Exit Function ErrorHandler: Debug.Print "Error in ArabicTextSanitizer: " & Err.Description ArabicTextSanitizer = "" End Function وهذه الوظيفة تبين اشكال وطرق الاستدعاء المختلفة ' Subroutine: TestArabicTextSanitizer ' Purpose: Demonstrates and validates the functionality of the ArabicTextSanitizer function. ' It shows various test cases for sanitizing Arabic text with diacritics, non-Arabic characters, and numbers. Sub TestArabicTextSanitizer() ' Declare input and result variables Dim inputArabicText As String Dim result As String ' Example input text with diacritics, non-Arabic characters, and numbers inputArabicText = "تَجْرِبَةُ * فَاحِصِهِ # @ , لِعَمَلٍ أَلِكَوَّدِ فِىَّ شَتِّيَّ 3ألْإِشْكآل " & _ "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 5 و الْمَكَانِ رَقْمٌ 100100ِ لمعرفة كيف سيعمل ها ألكود" ' Display the original input Arabic text Debug.Print "Input Arabic Text: " & inputArabicText ' Test case 1: Remove diacritics without normalization ' This case removes diacritics (harakat) without altering normalization or removing numbers result = ArabicTextSanitizer(inputArabicText, False, False) Debug.Print "Filtered Arabic Text (case 1 - Remove diacritics without normalization): " & result ' Test case 2: Normalize and remove diacritics ' This case normalizes the text (e.g., converting similar Arabic characters) and removes diacritics result = ArabicTextSanitizer(inputArabicText, True, False) Debug.Print "Normalized Arabic Text and Removed Diacritics (case 2): " & result ' Test case 3: Remove numbers as well (Optional argument set to True to remove numbers) ' This case normalizes the text and removes both diacritics and numbers result = ArabicTextSanitizer(inputArabicText, True, True) Debug.Print "Text without Numbers and Normalized (case 3): " & result ' Test case 4: Just remove diacritics without normalization or removing numbers ' This case removes diacritics and numbers, but does not normalize the text result = ArabicTextSanitizer(inputArabicText, False, True) Debug.Print "Text without Diacritics and Numbers (case 4): " & result End Sub واخيرا اليكم مرفق للتجربة Arabic Text Sanitizer.accdb

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تعقب التغييرات بين الجداول والمبنية على فكرة الأستاذ @ابو البشر ( مشكوراً ) مع إجراء بعض التعديلات ، بحيث تم منح المستخدم الحرية في اختيار جدولين ومفتاح ربط أساسي و مشترك فيما بينهم بشكل بسيط وسهل ، ولا يحتاج الأمر لأي مكتبات أو دعم خارجي . ⭐ ما احتجنا له هو كومبوبوكس عدد 3 ، وزر واحد فقط وظائفهم كالآتي :- cmbTable1 : التعرف على أسماء الجداول في قاعدة البيانات ، وهنا سيكون الجدول الأول . cmbTable2 : التعرف على أسماء الجداول في قاعدة البيانات باستثناء الجدول الذي تم اختياره في cmbTable1 ؛ والهدف هو عمل مقارنة بين جدولين وليس نفس الجدول . cmbPrimaryField : التعرف على أسماء الحقول في الجدول الأول ، ثم يتم اختيار الحقل المشترك أو المفتاح الأساسي من طرف المستخدم . btnExecute : منفّـذ العملية . ⭐ الأحداث والأكواد لكل جزء و عنصر في البرنامج :- في حدث عند التحميل للنموذج ، تم وضع الكود التالي لجلب أسماء الجداول إلى الكومبوبوكس ( cmbTable1 و cmbTable2 ) ، وطبعاً سيتم استثناء جداول النظام والجدول DifferencesTable الذي سيتم إدراج التغييرات فيه ( والذي سيتم انشائه بشكل ديناميكي في قاعدة البيانات عند المستخدم عند عدم وجوده ) . أي أنه وللإستفادة من البرنامج ما عليك إلا نسخ النموذج فقط الى مشروعك . Private Sub Form_Load() Me.cmbTable2.Enabled = False Me.cmbPrimaryField.Enabled = False Dim tdf As DAO.TableDef Me.cmbTable1.RowSource = "" Me.cmbTable2.RowSource = "" For Each tdf In CurrentDb.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" Then Me.cmbTable1.AddItem tdf.Name 'Me.cmbTable2.AddItem tdf.Name End If Next tdf End Sub في حدث بعد التحديث للكومبوبوكس cmbTable1 ، سيتم إدراج أسماء الجداول المتبقية كما ذكرت سابقاً في الكومبوبوكس cmbTable2 باستثناء ما تم اختياره في الجدول cmbTable1 :- Private Sub cmbTable1_AfterUpdate() Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Me.cmbPrimaryField.RowSource = "" Set db = CurrentDb Set tdf = db.TableDefs(Me.cmbTable1.Value) For Each fld In tdf.Fields Me.cmbPrimaryField.AddItem fld.Name Next fld Me.cmbTable2.RowSource = "" For Each tdf In db.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" And tdf.Name <> Me.cmbTable1.Value Then Me.cmbTable2.AddItem tdf.Name End If Next tdf Me.cmbTable2.Enabled = True Set fld = Nothing Set tdf = Nothing Set db = Nothing End Sub في حدث عند النقر على الزر btnExecute ، سيتم تنفيذ الكود التالي :- Private Sub btnExecute_Click() Dim db As DAO.Database Dim rsOld As DAO.Recordset Dim rsNew As DAO.Recordset Dim rsDifferences As DAO.Recordset Dim fld As DAO.Field Dim recordFound As Boolean Dim commonFields As Collection Dim fieldName As Variant Dim primaryField As String Dim table1 As String Dim table2 As String If IsNull(Me.cmbTable1) Then MsgBox "قم باختيار الجدول الأول", vbCritical, "" Me.cmbTable1.SetFocus Exit Sub ElseIf IsNull(Me.cmbTable2) Then MsgBox "قم باختيار الجدول الثاني", vbCritical, "" Me.cmbTable2.SetFocus Exit Sub ElseIf IsNull(Me.cmbPrimaryField) Then MsgBox "قم باختيار الحقل الأساسي", vbCritical, "" Me.cmbPrimaryField.SetFocus Exit Sub Else table1 = Me.cmbTable1.Value table2 = Me.cmbTable2.Value primaryField = Me.cmbPrimaryField.Value If IsNull(table1) Or IsNull(table2) Or IsNull(primaryField) Then MsgBox "Please select both tables and the primary field." Exit Sub End If Set db = CurrentDb If Not TableExists("DifferencesTable") Then CreateDifferencesTable db End If Set rsOld = db.OpenRecordset(table1) Set rsNew = db.OpenRecordset(table2) Set rsDifferences = db.OpenRecordset("DifferencesTable", dbOpenDynaset) DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM DifferencesTable;" DoCmd.SetWarnings True Set commonFields = New Collection For Each fld In rsOld.Fields On Error Resume Next If Not IsNull(rsNew.Fields(fld.Name).Name) Then If fld.Name <> primaryField Then commonFields.Add fld.Name, fld.Name End If End If On Error GoTo 0 Next fld Do While Not rsOld.EOF recordFound = False rsNew.MoveFirst Do While Not rsNew.EOF If rsOld(primaryField) = rsNew(primaryField) Then recordFound = True For Each fieldName In commonFields If Nz(rsOld(fieldName), "") <> Nz(rsNew(fieldName), "") Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Modification" rsDifferences("FieldName") = fieldName rsDifferences("OldValue") = rsOld(fieldName) rsDifferences("NewValue") = rsNew(fieldName) rsDifferences.Update End If Next fieldName Exit Do End If rsNew.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Deletion" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = "عملية حذف" rsDifferences("NewValue") = Null rsDifferences.Update End If rsOld.MoveNext Loop rsNew.MoveFirst Do While Not rsNew.EOF recordFound = False rsOld.MoveFirst Do While Not rsOld.EOF If rsNew(primaryField) = rsOld(primaryField) Then recordFound = True Exit Do End If rsOld.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsNew(primaryField) rsDifferences("ChangeType") = "Addition" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = Null rsDifferences("NewValue") = "عملية إضافة" rsDifferences.Update End If rsNew.MoveNext Loop rsOld.Close rsNew.Close rsDifferences.Close Set rsOld = Nothing Set rsNew = Nothing Set rsDifferences = Nothing Set db = Nothing End If CreatePivotQuery table1, table2 MsgBox "تمت عملية المقارنة في الجدولين ، وسيتم فتح الاستعلام بالنتائج", vbInformation, "" DoCmd.OpenQuery "Foksh", acViewNormal End Sub الكود يقوم بتنفيذ عملية مقارنة بين بيانات الجدولين ( من خلال اختيار الجدول الأول والجدول الثاني كما ذكرت سابقاً ) في أي قاعدة بيانات للمستخدم . وفيما يلي شرح مبسط للخطوات الرئيسية التي ينفذها هذا الكود ( للفائدة ):- التحقق من القيم في الكومبوبوكسات الثلاثة يتم التحقق مما إذا كان المستخدم قد اختار الجداول الأساسية ( الجدول الأول و الجدول الثاني ) وحقل المفتاح الأساسي للمقارنة . فإذا كانت أي من هذه المدخلات مفقودة أو لم يتم اختياره ، يعرض الكود رسالة تحذير بوجوب اختيار الجدول أو المفتاح الأساسي وبالتالي يوقف العملية . تحضير البيانات يتم فتح السجلات من الجداول المختارة (الجدول الأول والجدول الثاني) وإنشاء سجل جديد في جدول DifferencesTable لتخزين الفروقات والتغيرات . مقارنة البيانات سيقوم الكود بمقارنة السجلات في الجدولين اللذين تم اختيارهم سابقاً . فإذا كانت السجلات متطابقة في كلا الجدولين ، يتم مقارنة الحقول المشتركة فقط - أي الحقول الموجودة و المتشابهة بالإسم في الجدولين (باستثناء الحقل الأساسي) لتحديد التغييرات . فإذا كانت السجلات مفقودة في أحد الجدولين ( أي تم الحذف أو الإضافة في أي من الجدولين ) ، يتم تحديد نوع التغيير كـ ( عملية حذف ) أو ( عملية إضافة ). إدخال النتائج وإضافتها للجدول DifferencesTable يتم إضافة البيانات الناتجة عن التغييرات ( مثل القيمة القديمة والجديدة ) في جدول DifferencesTable ، مع تسجيل نوع التغيير ( إضافة، حذف، أو تعديل ) . إنشاء استعلام PIVOT أو ما يعرف بالإستعلام Crosstab بعد الانتهاء من المقارنة في الخطوة السابقة ، يتم إنشاء استعلام من نوع Pivot أو Crosstab ( استعلام جدولي كما يسمى في آكسس الواجهة العربية ) ؛ وهو يستخدم لتحويل البيانات من شكل الصفوف إلى شكل الأعمدة ( إن صح التعبير ) ، مما يجعل هذه البيانات أكثر تنظيماً وأسهل في التحليل و القراءةً . والهدف منه هو عرض التغييرات بطريقة منظمة باستخدام الحقول المشتركة بين الجدولين . فتح الاستعلام في نهاية الكود ، يتم فتح الاستعلام الذي يعرض الفروقات والتغيرات بين الجدولين بشكل عادي . ⭐ وظائف أخرى يتم استدعائها لأنشاء الجدول DifferencesTable بعد التأكد من وجوده أو لا . وأخرى لإنشاء الإستعلام الذي يحتوي التغيرات التي تم تعقبها :- وظيفة التأكد من وجود الجدول أو لا :- Function TableExists(tableName As String) As Boolean Dim db As DAO.Database Dim tdf As DAO.TableDef TableExists = False Set db = CurrentDb For Each tdf In db.TableDefs If tdf.Name = tableName Then TableExists = True Exit For End If Next tdf End Function في حال عدم وجود الجدول DifferencesTable ، سيتم استدعاء هذا الـ Sub لإنشائه مع الحقول التي سنحتاجها لعرض البيانات المختلفة في الجدولين :- Sub CreateDifferencesTable(db As DAO.Database) Dim tdf As DAO.TableDef Set tdf = db.CreateTableDef("DifferencesTable") tdf.Fields.Append tdf.CreateField("ID", dbLong) tdf.Fields.Append tdf.CreateField("ChangeType", dbText, 50) tdf.Fields.Append tdf.CreateField("FieldName", dbText, 50) tdf.Fields.Append tdf.CreateField("OldValue", dbMemo) tdf.Fields.Append tdf.CreateField("NewValue", dbMemo) db.TableDefs.Append tdf End Sub بعد تتبع التغيرات والفروقات ، سيتم انشاء استعلام باسم Foksh ، لعرض التغيرات التي تم التعرف عليها :- Sub CreatePivotQuery(table1 As String, table2 As String) Dim queryDef As DAO.queryDef Dim sql As String sql = "TRANSFORM First('" & table1 & " ' & [OldValue] & ' - ' & '" & table2 & " ' & [newvalue]) AS dd " & _ "SELECT DifferencesTable.ID " & _ "FROM DifferencesTable " & _ "GROUP BY DifferencesTable.ID " & _ "PIVOT DifferencesTable.FieldName;" On Error Resume Next CurrentDb.QueryDefs.Delete "Foksh" On Error GoTo 0 Set queryDef = CurrentDb.CreateQueryDef("Foksh", sql) Set queryDef = Nothing End Sub وأخيراً وليس آخراً :- UnMatched.accdb وهذه صورة للبرنامج :-

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

Gemini API.accdb

السلام عليكم 🙂 هذا الموقع يعطي ترتيب أكثر قواعد بيانات العالم استخداما: https://db-engines.com/en/ranking/relational+dbms والترتيب متغير شهريا ، ففي هذا الشهر: 6/2024 ، يكون ترتيب الاكسس رقم 8 عالميا : . واليكم طريقة تقييمهم للترتيب من: https://db-engines.com/en/ranking_definition وهنا تمت ترجمته آليا الى العربية: جعفر

لديك اخطاء في تحديد اسماء الخلايا كما في الصورة المرفقة تم تعديل الكود ليسهل التعامل معه Private Sub CommandButton2_Click() 'بحث Dim WS As Worksheet, F As Worksheet Dim Irow As Long, Clé As String, i As Long Set WS = Sheets("Sheet2"): Set F = Sheets("Sheet1"): Clé = F.[E3] Application.ScreenUpdating = False If Clé = Empty Then: MsgBox "برجاء إدخال اسم للبحث عن بياناته", vbCritical, "فلاح": Exit Sub Irow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row Set rng = WS.Range("B3:B" & Irow).Find(Clé, LookIn:=xlValues, _ lookat:=xlWhole, SearchDirection:=xlPrevious) If rng Is Nothing Then: MsgBox " الاسم غير موجود", vbExclamation, Clé: Exit Sub For i = 3 To Irow If WS.Cells(i, 2) = Clé Then ' Colmun (D) F.[D5] = WS.Cells(i, "B") F.[D7] = WS.Cells(i, "C"): F.[D9] = WS.Cells(i, "D"): F.[D11] = WS.Cells(i, "E") F.[D13] = WS.Cells(i, "F"): F.[D15] = WS.Cells(i, "G"): F.[D17] = WS.Cells(i, "H") F.[D19] = WS.Cells(i, "I"): F.[D21] = WS.Cells(i, "J"): F.[D23] = WS.Cells(i, "K") ' Colmun (G) F.[G7] = WS.Cells(i, "L"): F.[G9] = WS.Cells(i, "M"): F.[G11] = WS.Cells(i, "N") F.[G13] = WS.Cells(i, "O"): F.[G15] = WS.Cells(i, "P"): F.[G17] = WS.Cells(i, "Q") F.[G19] = WS.Cells(i, "R"): F.[G21] = WS.Cells(i, "S"): F.[G23] = WS.Cells(i, "T") ' Colmun (J) F.[J7] = WS.Cells(i, "U") F.[J9] = WS.Cells(i, "V"): F.[J11] = WS.Cells(i, "W") F.[J13] = WS.Cells(i, "X"): F.[J15] = WS.Cells(i, "Y") End If Next Application.ScreenUpdating = True End Sub مع تعديل كود الترحيل بالشكل التالي Private Sub CommandButton1_Click() ' اظافة Dim WS As Worksheet: Dim F As Worksheet Set WS = Sheets("Sheet1"): Set F = Sheets("Sheet2") Application.ScreenUpdating = False F.Range("B" & F.Rows.Count).End(xlUp).Offset(1).Resize(, _ 24).Value = Application.Index(WS.Range _ ("D5,D7,D9,D11,D13,D15,D17,D19,D21,D23,G7,G9,G11,G13,G15,G17,G19,G21,G23,J7,J9,J11,J13,J15"), _ 1, 1, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, _ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26)) With F.Range("A3:A" & F.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With Lr = F.Range("A65500").End(xlUp).Row b = F.Cells(2, F.Columns.Count).End(xlToLeft).Column F.Range(F.Cells(3, 1), F.Cells(Lr, b)).Borders.Weight = xlThin ' افراغ CommandButton4_Click Application.ScreenUpdating = True MsgBox "تم اضافة البيانات بنجاح" End Sub 123 (1).xlsm

السلام عليكم كنت ابحث عن برنامج على جهازي الكمبيوتر بالصدفة وجدت هذا الملف الرائع احببت المشاركة معكم للفائدة اكواد كسس مهمة.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Dim tmps As Object, cell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If tmps Is Nothing Then Set tmps = CreateObject("Scripting.Dictionary") If Target.Cells.Count > 1 Then Exit Sub For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing Then tmps(cell.Address) = cell.Value Next cell ExitHandler: Exit Sub ClearApp: Set tmps = Nothing Resume ExitHandler End Sub Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ClearApp If Target Is Nothing Or tmps Is Nothing Then Exit Sub With Me.Shapes("CheckBox1").ControlFormat If .Value = xlOff Then Exit Sub End With If Target.Cells.Count > 1 Then Exit Sub Application.EnableEvents = False For Each cell In Target If Not Intersect(cell, Me.Range("A1:P40")) Is Nothing And tmps.exists(cell.Address) Then If IsNumeric(cell.Value) Then cell.Value = tmps(cell.Address) + cell.Value Else MsgBox cell.Address & " : " & "تم إدخال قيمة غير صالحة في الخلية ", vbExclamation End If End If Next cell ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub جمع الخلية v3.xlsb

المفروض أن الكود التالي يشتغل معك Sub SortStudents() Dim WS As Worksheet Dim lastRow As Long Dim OnRng As Range Set WS = ThisWorkbook.Sheets("Sheet1") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If lastRow < 2 Then Application.ScreenUpdating = True Exit Sub End If Set OnRng = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear .SortFields.Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .SortFields.Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending, DataOption:=xlSortNormal .SortFields.Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending .SetRange OnRng .Header = xlYes .Apply End With Application.ScreenUpdating = True End Sub ترتيب الاوائل v3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb

وعليكم السلام ورحمة الله وبركاته 🙂 عملت شيء مشابه لهذا سابقا .. فقط يمكن تعديله ليتوافق مع الحاجة 🙂 ‏‏Meter -Moosak _ Final.accdb

وعليكم السلام ورحمة الله تعالى وبركاته كما سبق الدكر من الأستاد @عبدالله بشير عبدالله طلبك غير واضح إظافة أن أرقام الأعمدة على الملف تتواجد في الصف 3 ليس 2 مجرد تخمين ربما تقصد جلب بيانات العمود بشرط إدخال قيمة رؤوس الأعمدة (رقم العمود) جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Variant, tmp As Variant, lastRow As Long, a As Long, Clé As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, WS.Range("AQ3:BO3")) Is Nothing Then lastRow = WS.Columns("A:Z").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row OnRng = WS.Range("A4:Z" & lastRow).Value tmp = WS.Range("A3:Z3").Value Clé = Target.Value Application.ScreenUpdating = False If IsEmpty(Target.Value) Then WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)).ClearContents Else For a = 1 To UBound(tmp, 2) If tmp(1, a) = Clé Then With WS.Range(WS.Cells(4, Target.Column), WS.Cells(lastRow, Target.Column)) .ClearContents .Value = Application.Index(OnRng, 0, a) End With Exit For End If Next a End If If a > UBound(tmp, 2) Then Target.ClearContents: MsgBox "لم يتم العثور على " & _ Target.Value & " في قاعدة البيانات", vbExclamation, "إنتبـــاه" End If Application.ScreenUpdating = True End Sub استخراج الاعمدة.xlsm

وعليكم السلام ورحمة الله وبركانه لم نوضح لنا مكان كتابة النتائج النهائية وكيف ترغب شكلها النهائي في الملف العمود c كلمة نطايق نعنى ان لها مثيل في العمودين d-e وفي العمود f كلمة نطايق نعنى ان لها مثيل في العمودين A - B الكود Sub CompareTablesInOneSheet() Dim ws As Worksheet Dim lastRow1 As Long Dim lastRow2 As Long Dim i As Long Dim j As Long Set ws = ThisWorkbook.Sheets("ورقة1") lastRow1 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row lastRow2 = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row ws.Range("C2:C" & lastRow1).ClearContents ws.Range("F2:F" & lastRow2).ClearContents For i = 2 To lastRow1 For j = 2 To lastRow2 If ws.Cells(i, 1).Value = ws.Cells(j, 4).Value And ws.Cells(i, 2).Value = ws.Cells(j, 5).Value Then ws.Cells(i, 3).Value = "متطابق" ws.Cells(j, 6).Value = "متطابق" Exit For End If Next j If ws.Cells(i, 3).Value <> "متطابق" Then ws.Cells(i, 3).Value = "غير متطابق" End If Next i For j = 2 To lastRow2 If ws.Cells(j, 6).Value <> "متطابق" Then ws.Cells(j, 6).Value = "غير متطابق" End If Next j MsgBox "تم مقارنة البيانات بنجاح!" End Sub الملف Test.xlsb

وعليكم السلام ورحمه الله وبركاته ممكن تستخدم الكود التالي لعله المطلوب Sub ColorCellsAboveYellow() Dim ws As Worksheet Dim cell As Range Dim targetColor As Long Dim i As Integer Set ws = ThisWorkbook.Sheets("Sheet1") targetColor = RGB(255, 255, 0) For Each cell In ws.UsedRange If cell.Interior.Color = targetColor Then For i = 1 To 2 If cell.Row - i > 0 Then ws.Cells(cell.Row - i, cell.Column).Interior.Color = targetColor End If Next i End If Next cell End Sub Book1.xlsm

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

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

السلام عليكم ورحمه الله وبركاته دا جزاء من مشروع شغال عليه يلمس هذا الموضوع ساقوم بإرفاق ملف الوظائف التي يقوم بها 1- تعطيل / تفعيل مفتاح الشفت 2-ربط ديناميكي / ربط يدوي لــ الواجهات الاماميه (النماذج) مع الواجهات الخلفيه (الجداول) 3-اخفاء جميع كائنات الاكسس الواجهات الاماميه (النماذج) مع عدم القدره ع استيرادها من ملف اكسس اخر 4-اخفاء جميع كائنات الاكسس من الواجهات الخلفيه (الجداول) مع عدم القدره ع استيرادها من ملف اكسس اخر يرجي الافاده بعد التجربه خاص اوفسينا.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

المطلوب منك هتعلن عن متغير عام على مستوى النموذج Private SortAscending As Boolean هتحتاج الى هذا الصب Private Sub SortRecords(ByVal FieldName As String) Dim OrderDirection As String If SortAscending Then OrderDirection = " ASC" Else OrderDirection = " DESC" End If Me.OrderBy = FieldName & OrderDirection Me.OrderByOn = True SortAscending = Not SortAscending End Sub وفى كل تسميه هتيجي عن حدث عند الضغط وتستدعي الصب مثل SortRecords "Nr" لاحظ انى هنا احتجت اى اسم الحقل (كما هو فى الجدول) لهذا الصب مرفق الملف بعد التعديل db1.rar