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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

الموضوع تعبنى جدا والله وكان تحدى صعب احب التنويه الى شئ استخدام sleep اثناء العمل قد يصيب الأكسس بالتجميدوالشلل وقد يعلق فى الذاكرة ولذلك ابتعدت عن ضبط الاكواد من خلالها واليكم نتيجة التحدى اولا تم مراعاة وضع الاكواد فى وحدة نمطية ليتم استخدامها فى اكثر من نموذج حتى لو اختلف وتعددت الوان أزرار الأوامر ومهما اختلفت اسماء او عناوين الأزرار وفى حاجة كمان لو عاوزيين نلون لون الزرار بالاصفر بس ومنغيرش تسمية عنصر التسمية ممكن جدا جدا ومن نفس الكود يعنى كود ذكى وابن حلال وبيقدر يفهمنا من أول تكه على الزرار اه والله زيمبئولكم كده.. شغل فاخر من الاخر اومااااااااااال 1- أكواد الوحدة النمطية Option Compare Database Option Explicit ' Constant that specifies the time interval for color flashing (in seconds) Const dblTimeInterval As Double = 0.5 ' Constant that determines the number of times the colors will flash Const intFlashCount As Integer = 5 ' Variable to track whether Label flashing should occur Public AllowFlashing ' Public variables to store default values Public btnControlDefaultColor As Long Public lblControlDefaultColor As Long Public strLblControlCaption As String Public formIsClosing As Boolean ' Public variable to store the selected button Public selectedButton As CommandButton ' Function to return the highlighted color Function ApplyHighlighted() As Long ApplyHighlighted = RGB(255, 255, 0) End Function ' Subroutine to set the button color Sub ButtonColor(ByVal frm As Form, Optional btn As CommandButton = Nothing, Optional DisableLabelChange As Boolean) ' Set the default button color if not highlighted If Not btn Is Nothing Then If btn.BackColor <> ApplyHighlighted Then btnControlDefaultColor = btn.BackColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = btnControlDefaultColor End If ' Set the new button as selected and highlight it btn.BackColor = ApplyHighlighted ' Save the caption of the current button If Not DisableLabelChange Then strLblControlCaption = btn.Caption End If Set selectedButton = btn End If End Sub ' Subroutine to flash the label control Sub FlashLabelControl(frm As Form, lblControl As Object, DisableLabelChange As Boolean) On Error GoTo ErrorHandler Dim flashingColor As Long Dim flashingInterval As Single Dim flashCount As Integer Dim flashTimer As Single Dim i As Integer On Error GoTo 0 ' Turn off error trapping. On Error Resume Next ' Defer error trapping. ' Set the default label color if not highlighted If lblControl.BackColor <> ApplyHighlighted Then lblControlDefaultColor = lblControl.BackColor flashingColor = ApplyHighlighted flashingInterval = dblTimeInterval flashCount = intFlashCount ' Reset the label color to the default when the form is loaded If TypeOf lblControl Is Access.Label And Not formIsClosing Then lblControl.BackColor = lblControlDefaultColor If Not DisableLabelChange Then lblControl.Caption = strLblControlCaption End If End If flashTimer = Timer + flashingInterval ' Flash the label color For i = 1 To flashCount Do While Timer < flashTimer And Not formIsClosing DoEvents Loop ' Update the label color during the flash If TypeOf lblControl Is Access.Label And Not formIsClosing Then If AllowFlashing Then ' Check the AllowLabelCaptionChange value to determine whether to change the caption If Not DisableLabelChange Then lblControl.Caption = IIf(lblControl.Caption = strLblControlCaption, strLblControlCaption, vbNullString) End If lblControl.BackColor = IIf(lblControl.BackColor = lblControlDefaultColor, flashingColor, lblControlDefaultColor) End If End If ' Update the flash timer flashTimer = Timer + flashingInterval Next i ' Reset the label color to the default after flashing If TypeOf lblControl Is Access.Label And Not formIsClosing Then lblControl.BackColor = lblControlDefaultColor If Not DisableLabelChange Then lblControl.Caption = strLblControlCaption End If End If ' 2467 Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 2467 flashCount = 0 flashTimer = 0 Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox Err.Number & ": " & Err.Description Resume ' Resume execution at the same line End Select End Sub ' Subroutine to change the button color and control Label flashing Sub ChangeCommandButtonColor(frm As Form, Optional lblControl As Object, Optional DisableLabelChange As Boolean) On Error GoTo ErrorHandler Dim clickedButton As CommandButton Set clickedButton = frm.ActiveControl On Error GoTo 0 ' Turn off error trapping. On Error Resume Next ' Defer error trapping. ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = btnControlDefaultColor lblControl.Caption = "" strLblControlCaption = "" End If ' Set the new button as selected and highlight it Set selectedButton = clickedButton ' Update the label caption If Not DisableLabelChange Then strLblControlCaption = clickedButton.Caption End If ' Apply the button color and control Label flashing ButtonColor frm, clickedButton, True ' Check if lblControl is provided and is a valid object If Not lblControl Is Nothing Then AllowFlashing = Not DisableLabelChange ' Determine whether to trigger flashing lblControl.Caption = strLblControlCaption FlashLabelControl frm, lblControl, False End If Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 5 Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox Err.Number & ": " & Err.Description Resume ' Resume execution at the same line End Select End Sub 2- الاكواد للاستخدام من خلال النموذج ولا اسهل من كده.. يا عينى ع الدلع Private Sub Form_Load() formIsClosing = False End Sub Private Sub Form_Close() formIsClosing = True End Sub Private Sub Command1_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command2_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command3_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command4_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command5_Click() ' Call the ChangeCommandButtonColor subroutine with the current form only without label control (lblDisplayTitle). ' To disable Allow Label Caption Change = True ChangeCommandButtonColor Me, Me.lblDisplayTitle, True End Sub معلش انا شرحت كل شئ ع الأكواد بالانجليزى طبعا مش فلسفة علشان عارف انت هتقول ايه سامعك... علشان العربى بيعمل مشاكل فى الاعدادت الاقليمية للغة لو مكانت مضبوطه بس خلاص • وأخيرا المرفق FlashLabel.accdb

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

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

لم اجد تفاعل أو اى رد يدل على نجاح فاعلية التطبيق والتجربة وهذه القواعد للتجربة تم مراعاة عند كتابة الأكواد العمل على كل من النواتان 32x , 64x استاذى الجليل الاستاذ @Moosak اردت فقط الاطمئنان على المكتبة العامرة Moh3sam.zip

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

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

السلام عليكم : اعضاء المنتدي من خبايا الرقم القومي . صممت هذ البرنامج وبدون اكواد لان في اعضاء كتير يحتاجون هذه المعلومات . الصورة توضح اكثر ... my_data.xlsx

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

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

تفضل هذا بمعادلة مصفوفة (Ctrl+Shift+Enter) Report Between Two Dates.xlsb

:: السلام عليكم ورحمة الله وبركاته :: لا بد بين فترة وأخرى من اقتحام مجالات جديدة وتنمية المهارات البرمجية لدى للمبرمج 🙂 هذي المرة طرح أخي @TQTHAMI فكرة برنامج للكلمات المتقاطعة ، فلمعت في رأسي الفكرة وقررت خوض التجربة فنتج عنها ما يلي☺️ :: ((( لعبة الكلمات المتقاطعة ))) :: وهنا بعض الصور واللقطات للعبة إضافة لعبة جديدة وتصميمها :: وأخيرا تحميل الملف المفتوح 😊 :: لعبة الكلمات المتقاطعة.accdb :: ((( الإصدار الثاني 2.0 ))) :: أضفت زرين في نافذة إعداد اللعبة : طباعة اللعبة / طباعة الحل : التحميل 🙂 : ‏‏لعبة الكلمات المتقاطعة الإصدار 2.accdb1.63 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 0 downloads

السلام عليكم 🙂 هذا الموقع يعطي ترتيب أكثر قواعد بيانات العالم استخداما: 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

ما فيه .. هذا حمود وهذي عباته لما طلع vb6 من بيتهم القديم وطلع يجدد بيته .. اكسس حل محله وجلس في البيت القديم

السلام عليكم اعضاء الكنترول الكرام اضع بين ايديكم شيت كنترول جدارات _ قسم حاسبات " الصف الاول "_ مفتوح المصدر يشتمل على ♦ شيت الرصد ♦ شهادات التيرم الاول ♦ شهادات نهاية العام ♦ تحديد الاوائل في الشهادة " هذا العمل خالصا لوجه الله تعالى " hasbat_1_gdarat.xlsm

لتصميم الشاشة الرئيسية وسهولة التحكم فىيها تم اضافة جدول جديد باسم tblFormsTitle يتكون من الحقول FormName = اسم النموذج الفرعى FormDesc = وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) TitleForm = العنوان فى الشاشة الرئيسية البيانات داخل الجدول كالاتى اسم النموذج الفرعى وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) العنوان فى الشاشة الرئيسية frmHomeMenu HomeMenu الرئيسية frmSub1ImportOraclExcel ImportExcel استيراد بيانات الحضور والانصراف ( Oracle's Excel sheet ) frmSub2DailyEmployee DailyEmployee ادارة يوميات الموظفين ( اضافة / تعديل / حذف ) frmSub3QueryDaily QueryDailyBy استعلام وتقارير يوميات الموظفين frmSub4Employees EmployeesData ادارة بيانات الموظفين ( اضافة / تعديل / حذف ) frmSub5DailyLogsType DailyLogsType ادارة انواع اليوميات ( اضافة / تعديل / حذف ) frmSub6Department Department ادارة بيانات الادارات و المديرين ( اضافة / تعديل / حذف ) frmSub7Section Section ادارة بيانات الاقسام ( اضافة / تعديل / حذف ) تم تصميم النماذج الفرعية بدون اى مصدر بيانات .... عمل نموذج رئيسي باسم frmMain فى وضع التصميم تم اضافة نموذج فرعى غير منضم باسم subformControl تم اضافة مربع تسمية ( Lable ) باسم lblTitle اضافة عدد سبع ازرار باسماء btnNavItem1 ,btnNavItem2 , btnNavItem3 , ........ الخ عنصر تحكم صورة باسم imgArrow يحتوى على شكل سهم الاكواد فى النموذج قائمة بوظائف الازرار تبعا لوصف النماذج من الجدول والذى اشرنا الى الحقل الخاص به وصف النموذج ( معيار احضار بيانات اسم النموذج والعنوان فى الكود) ' Enum to define button actions Enum ButtonAction HomeMenu ImportExcel DailyEmployee QueryDailyBy EmployeesData DailyLogsType Department Section End Enum متغيرات لاسناد قيم اليها ' Declare variables to store form name and title Private strFormName As String Private strTitleForm As String Private subformInfoArray As Variant دالة لتحديد المعيار لجلب البيانات للنماذج الفرعية من الجدول ( اسم النموذج - العنوان فى الشاشة الرئيسية ) بناء على Enum قائمة الازرار ' Sub to handle button click events Private Sub HandleButtonClick(btnAction As ButtonAction) Dim subformInfoResult As String ' Get subform information based on the button action subformInfoResult = GetSubformInfo(ButtonActionToString(btnAction)) ' Process the subform information and update the form ProcessSubformInfo subformInfoResult End Sub دالة لاحضار معلومات النماذج الفرعية من الجدول ( اسم النموذج - العنوان فى الشاشة الرئيسية ) بناء على المعيار من الدالة السابقة ' Function to get the name and title of the subform based on the form description Function GetSubformInfo(subformDesc As String) As String ' Use On Error Resume Next to handle errors gracefully On Error Resume Next ' Declare a DAO Recordset variable Dim rs As DAO.Recordset ' Open a recordset based on the provided form description Set rs = CurrentDb.OpenRecordset("SELECT FormName, TitleForm FROM tblFormsTitle WHERE FormDesc='" & subformDesc & "'") ' Check if the recordset is not empty If Not rs.EOF Then ' Return the concatenated string of FormName and TitleForm GetSubformInfo = rs!formName & "," & rs!titleForm Else ' Return an empty string if no matching record is found GetSubformInfo = "" End If ' Close the recordset to free up resources rs.Close Set rs = Nothing ' Check for errors and display debug information If Err.Number <> 0 Then MsgBox "Error retrieving subform information: " & Err.Description, vbExclamation Err.Clear End If End Function دالة لفصل اسم النموذج والعنوان والذى تم الحصول عليهم من الدالة السابقة ' Sub to process subform information and update the form Sub ProcessSubformInfo(subformInfoResult As String) ' Split the subformInfo into an array subformInfoArray = Split(subformInfoResult, ",") ' Extract the formName and title from the array If UBound(subformInfoArray) >= 1 Then strFormName = Trim(subformInfoArray(0)) strTitleForm = subformInfoArray(1) End If ' Update the form based on the subform information UpdateFormBasedOnSubformInfo End Sub دالة للتحكم فى اظهار واخفاء موضع صورة سهم تدل على النموذج الفرعى تبعا لزر الامر ' Sub to move the arrow indicator on the form Sub MoveArrow() ' Make the arrow visible and position it below the active control If Not Me.imgArrow.Visible Then Me.imgArrow.Visible = True Me.imgArrow.Top = Me.ActiveControl.Top ChangeCommandButtonColor Me End Sub دالة تحديث النموذج بناء على المعطيات السابقة من الدوال بمجرد النقر على زر الامر ' Sub to update the form based on the subform information Sub UpdateFormBasedOnSubformInfo() Select Case Nz(strFormName, "frmHomeMenu") Case Is = "frmHomeMenu" Me.lblTitle.Caption = strTitleForm subformControl.Visible = False ChangeCommandButtonColor Me, False Me.imgArrow.Visible = False Me.subformControl.SourceObject = "" Me.subformControl.Height = 0 Case Else Me.lblTitle.Caption = strTitleForm MoveArrow ChangeCommandButtonColor Me Me.subformControl.Height = BoxMain.Height Me.subformControl.SourceObject = strFormName subformControl.Visible = True End Select End Sub الاكواد لضبط وتحديد الحدث المراد تنفيذه تبعا لازرار الاوامر ' Function to convert ButtonAction to corresponding form description Function ButtonActionToString(btnAction As ButtonAction) As String Select Case btnAction Case ButtonAction.HomeMenu: ButtonActionToString = "HomeMenu" Case ButtonAction.ImportExcel: ButtonActionToString = "ImportExcel" Case ButtonAction.DailyEmployee: ButtonActionToString = "DailyEmployee" Case ButtonAction.QueryDailyBy: ButtonActionToString = "QueryDailyBy" Case ButtonAction.EmployeesData: ButtonActionToString = "EmployeesData" Case ButtonAction.DailyLogsType: ButtonActionToString = "DailyLogsType" Case ButtonAction.Department: ButtonActionToString = "Department" Case ButtonAction.Section: ButtonActionToString = "Section" End Select End Function الاكواد على ازرار الاوامر Private Sub ImageLogo_Click() HandleButtonClick HomeMenu End Sub Private Sub btnNavItem1_Click() HandleButtonClick ImportExcel End Sub Private Sub btnNavItem2_Click() HandleButtonClick DailyEmployee End Sub Private Sub btnNavItem3_Click() HandleButtonClick QueryDailyBy End Sub Private Sub btnNavItem4_Click() HandleButtonClick EmployeesData End Sub Private Sub btnNavItem5_Click() HandleButtonClick DailyLogsType End Sub Private Sub btnNavItem6_Click() HandleButtonClick Department End Sub Private Sub btnNavItem7_Click() HandleButtonClick Section End Sub واخيرا وحدة نمطية باسم basChangeButtonColor خاصة بتغير لون زر الامر الذى يتم الضغط عليه فى النموذج الرئيسى ' Enum for colors Enum ColorEnum WhiteColor = 16777215 ' White RedColor = 255 ' Red GreenColor = 32768 ' Green BlueColor = 16711680 ' Blue PurpleColor = 8388736 ' Purple GrayColor = 8421504 ' Gray OrangeColor = 16753920 ' Orange BrownColor = 10824234 ' Brown BlackColor = 0 ' Black CyanColor = 16776960 ' Cyan MagentaColor = 16711935 ' Magenta YellowColor = 65535 ' Yellow LightBlueColor = 173216230 ' Light Blue DarkGreenColor = 65280 ' Dark Green PinkColor = 16761035 ' Pink LavenderColor = 230230250 ' Lavender OliveColor = 32896 ' Olive AquaColor = 65535 ' Aqua TurquoiseColor = 4251856 ' Turquoise GoldColor = 16766720 ' Gold SilverColor = 12632256 ' Silver MaroonColor = 8388608 ' Maroon NavyColor = 128 ' Navy TealColor = 8421376 ' Teal CoralColor = 5275647 ' Coral SalmonColor = 16416882 ' Salmon IndigoColor = 4915330 ' Indigo PeachColor = 16775640 ' Peach SiennaColor = 10506797 ' Sienna SkyBlueColor = 8900331 ' Sky Blue End Enum ' Module-level variables Dim currentButtonBackColor As Long ' Variable to store the current button back color Dim currentButtonForeColor As Long ' Variable to store the current button fore color Dim selectedButton As CommandButton ' Variable to store the selected button ' Subroutine to set the button color Sub SetButtonColor(ByVal frm As Form, Optional btn As CommandButton = Nothing) ' Set new button colors Dim newButtonBackColor As Long Dim newButtonForeColor As Long newButtonBackColor = ColorEnum.GrayColor newButtonForeColor = ColorEnum.BlackColor If Not btn Is Nothing Then ' Store the current button's colors currentButtonBackColor = btn.BackColor currentButtonForeColor = btn.ForeColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = currentButtonBackColor selectedButton.ForeColor = currentButtonForeColor End If ' Set the new button as selected and highlight it Set selectedButton = btn btn.BackColor = newButtonBackColor btn.ForeColor = newButtonForeColor End If End Sub ' Subroutine to change the button color Sub ChangeCommandButtonColor(frm As Form, Optional changeColor As Boolean = True) On Error GoTo ErrorHandler Dim clickedButton As CommandButton Set clickedButton = frm.ActiveControl ' Store the default button colors before changing Dim currentButtonBackColor As Long Dim currentButtonForeColor As Long currentButtonBackColor = clickedButton.BackColor currentButtonForeColor = clickedButton.ForeColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = currentButtonBackColor selectedButton.ForeColor = currentButtonForeColor End If ' Set the new button as selected and highlight it Set selectedButton = clickedButton ' Apply the button color if changeColor is True If changeColor Then SetButtonColor frm, clickedButton End If Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 5 Resume Next Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox "Error: " & Err.Number & vbCrLf & "Description: " & Err.Description Resume ' Resume execution at the same line End Select End Sub المميزات : 1- عند الابتعاد عن الشاشة والعودة مرة أخرى بمجرد النظر يمكنك معرفة الزر الاخير الذى تم الضغط عليه 2-سهولة تغيير العناوين التى تظهر على الشاشة الرئيسية تبعا لكل نموذج فرعى بكل سهولة بدون داعى للدخول الى عرض التصميم من الجدول اختبار تجربة يتبع ... واخيرا المرفق HRManagement V 1.0.2.zip

تم تعديل البرنامج مع اضافة الباركود اسفل الورقة. *ملاحظة هامة* يتم تثبيت خطوط الباركود المرفقه مع البرنامج لكي يظهر الباركود بصورة صحيحة اسفل ورقة الاختبار برنامج طباعة الاختبارات تعديل نهائي٣.rar

وعليكم السلام أهلا وسهلاً بك بالمنتدى , كان لابد من رفع ملف لتوضيح المطلوب بكل دقة وتجنباً لإهدار وقت كل من يود مساعدتك .. ولكن عموماً بإفتراض ان الرقم المراد تقسيمه الى سنوات وشهور وأيام موجود بالخلية A2 فستكون المعادلات كالتالى =INT(A2/360) 'الشهور =INT(MOD(A2,360)/30) 'الأيام =MOD(A2,30)

الحمدلله أكتملت الفكرة والتنفيذ 🙂 عملت نموذجين .. وتبقى تكملة المشروع لتكون صفحة تسجيل دخول مكتملة 🙂 النمط الأول : النمط الثاني : للتحميل : MoosaK_Pattern_Lock.accdb

السلام عليكم ورحمة الله وبركاته قبل عامين تقريباً كنت قد بدأت بتصميم برنامج إدارة و حضور وانصراف لنادي رياضي أو لياقة بدنية . واليوم سأطرح البرنامج مع بعض التعديلات البسيطة التي جرت عليه كهدية وتجربة قابلة للتطوير والتحديث ومفتوح المصدر . Password : admin GYM 2022 - Final.zip الدعاء لوالدي رحمه الله ، ولوالدتي بالشفاء التام

السلام عليكم بها نبدأ أى مشاركة -بما انك لم تقم برفع ملف -فيمكنك استخدام هذا الكود لطلبك: Sub ColorCompanyDuplicates() Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xChar As String Dim xCellPre As Range Dim xCIndex As Long Dim xCol As Collection Dim i As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub xCIndex = 2 Set xCol = New Collection For Each xCell In xRg On Error Resume Next If xCell.Value <> "" Then xCol.Add xCell, xCell.Text If Err.Number = 457 Then xCIndex = xCIndex + 1 Set xCellPre = xCol(xCell.Text) If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex ElseIf Err.Number = 9 Then MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel" Exit Sub End If On Error GoTo 0 End If Next End Sub

يمكنك استعمال هذا الكود وتنفيذه في شيت الترحيل وليس في sheet1 Sub mas_taqseem() Application.ScreenUpdating = False lr = Sheet1.Cells(10000, 1).End(xlUp).Row Range("A2:K100").ClearContents col = 1 For i = 2 To lr Step WorksheetFunction.Ceiling((lr - 1) / 3, 1) For j = 2 To WorksheetFunction.Ceiling((lr - 1) / 3, 1) + 1 Cells(j, col) = Sheet1.Cells(j + i - 2, 1) Cells(j, col + 1) = Sheet1.Cells(j + i - 2, 2) Cells(j, col + 2) = Sheet1.Cells(j + i - 2, 3) Next j col = col + 4 Next i Application.ScreenUpdating = True MsgBox "Done by mr-mas.com" End Sub بالتوفيق

تفضل عمل احصائية.xlsm

السلام عليكم -يمكنك ذلك بإستخدام هذه المعادلة داخل Data Validation =YEAR($C2)<=2000 عدم قبول ادخال تاريخ قبل سنة معينة.xlsx

وعليكم السلام-ياريت تقوم بتغيير عنوان المشاركة ليصبح ( معادلة IF متعددة الشروط) وهذه المعادلة تفى بالغرض وشكراً =IF(AND($C4<>"غ",$B4="ذكر"),"ناجح",IF(AND($C4<>"غ",$B4="أنثي"),"ناجحة",IF(AND($C4="غ",$B4="ذكر"),"ناجح بحكم القانون",IF(AND($C4="غ",$B4="أنثي"),"ناجحة بحكم القانون","")))) معادلة IF.xlsx