ابو جودي

تقصد دماغى واللا دماغك انت ؟. انا عن نفسي عمرها ما تعمل error لان مفيش دماغ اساسا

واتفضلوا هذا المرفق يعتمد فقط على الرقم القومى فى عمل كل شئ اعتقد كده يا استاذ @Lotfy14 ويا استاذ @أحمد العيسى هذا المرفق الاخيــر يشمل كل التفاصيل من خلال الرقم القومى الان الرقم القومى بمجرد كتابته يتم الحصول على كافة البيانات التالية تاريخ الميلاد الجنس مكان الميلاد العمر بالسنوات العمر بالأشهر العمر بالأيام سن التقاعد تاريخ التقاعد السنوات المتبقية لبلوغ سن التقاعد الأشهر المتبقية لبلوغ سن التقاعد الأيام المتبقية لبلوغ سن التقاعد مع المرونة المطلقه فى تغير قيمة المتعير من يريد خصم اليوم يستخدم المتغير التالى ' تعيين قيمة التعديل adjustmentDays = -1 ' طرح يوم واحد من تاريخ التقاعد ومن لا يريد خصم يوم يستخدم المتغير بالشكل التالى ' تعيين قيمة التعديل adjustmentDays = 0 عدم طرح او زياده اى يوم لتاريخ التقاعد سن التقاعد (7).accdb

ولا يهمك ده مرفقك بعد التعديل تدلل بيانات المدرسين (1).zip

تجرب ورايا تصدق زعلتنى يا راجل دا شغل فاخر من الاخر ايه اللى انت بتقوله ده هو انت شايفنى بنى ادم طبيعى واللا عاقل عل كل حال تم تغير الوظيفه : GetRetirementInfo بالوظيفة الجديده التاليه ' دالة لحساب تفاصيل التقاعد بناءً على تاريخ الميلاد ' الغرض: تحديد سن التقاعد، تاريخ التقاعد، والوقت المتبقي (سنوات، أشهر، أيام) ' المعاملات: ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' - showDetails (Boolean, اختياري): إذا كان True، يتم إرجاع التفاصيل الكاملة، وإذا كان False يتم إرجاع تاريخ التقاعد فقط ' الإرجاع: سلسلة نصية تحتوي على نتائج الحسابات أو رسالة خطأ إذا كان المدخل غير صالح Public Function GetRetirementInfo(birthDate As Date, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer ' سن التقاعد Dim RetirementDate As Date ' تاريخ التقاعد Dim remainingYears As Integer ' السنوات المتبقية Dim remainingMonths As Integer ' الأشهر المتبقية Dim remainingDays As Integer ' الأيام المتبقية Dim result As String ' النتيجة النهائية Dim currentDate As Date ' التاريخ الحالي Dim tempDate As Date ' تاريخ مؤقت Dim adjustmentDays As Integer ' تعديل الأيام ' تعيين قيمة التعديل adjustmentDays = -1 ' طرح يوم واحد من تاريخ التقاعد ' التحقق من صحة تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "" Else birthDate = CDate(birthDate) ' تحديد سن التقاعد بناءً على تاريخ الميلاد If birthDate < DateSerial(1971, 7, 1) Then retirementAge = 60 ElseIf birthDate < DateSerial(1972, 7, 1) Then retirementAge = 61 ElseIf birthDate < DateSerial(1973, 7, 1) Then retirementAge = 62 ElseIf birthDate < DateSerial(1974, 7, 1) Then retirementAge = 63 ElseIf birthDate < DateSerial(1975, 7, 1) Then retirementAge = 64 Else retirementAge = 65 End If ' حساب تاريخ التقاعد RetirementDate = DateAdd("yyyy", retirementAge, birthDate) ' إضافة سن التقاعد RetirementDate = DateAdd("d", adjustmentDays, RetirementDate) ' تطبيق التعديل ' إذا طُلبت التفاصيل If showDetails Then currentDate = Date remainingYears = DateDiff("yyyy", currentDate, RetirementDate) tempDate = DateAdd("yyyy", remainingYears, currentDate) If tempDate > RetirementDate Then remainingYears = remainingYears - 1 tempDate = DateAdd("yyyy", remainingYears, currentDate) End If remainingMonths = 0 While DateAdd("m", 1, tempDate) <= RetirementDate remainingMonths = remainingMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend remainingDays = DateDiff("d", tempDate, RetirementDate) result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & RetirementDate & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else result = "تاريخ التقاعد: " & RetirementDate End If End If GetRetirementInfo = result End Function من يريد خصم اليوم يستخدم المتغير التالى ' تعيين قيمة التعديل adjustmentDays = -1 ' طرح يوم واحد من تاريخ التقاعد ومن لا يريد خصم يوم يستخدم المتغير بالشكل التالى ' تعيين قيمة التعديل adjustmentDays = 0 عدم طرح او زياده اى يوم لتاريخ التقاعد وده المرفق سن التقاعد (6).accdb

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

سبحانك لا علم لنا الا ما علمتنا انك انت الحكيم العليم كل الفضل والشكر لله سبحانه وتعالى الذى هدانا وما كنا لنهتدى لو لا ان هدانا الله عزوجل هذا فضل الله ثم اساتذتنا العظماء الذين نتعلم منهم وعلى اياديهم انا مجرد سبب فقط لا اكثر من ذلك و لا اقل اعتقد والله اعلم أن 7/1 هو الصحيح اولا هو الموجود فى ملف الاكسل المرفق للاستاذ @Lotfy14 ثانيا شهر 7 هو بداية العام المالى الجديد لذلك هو اوقع من شهر 1 من وجهة نظرى المتواضعة ثالثا عندما أبحث على الانترنت لا اعتمد الا النتائج من المصادر الموثوقة مثل الدستور مثلا وهاكم رابط المصدر الذى استندت اليه https://www.dostor.org/4831633 واخيرا اجابتى فى هذه النقطه مجرد اجتهاد شخصى قد أخطى وقد أصيب لذلك من يهتم يتأكد من المعلومات الصحيحة من جانبه

انتم احد اهم ركائز المنتدى واحد اعظم الاساتذة الذين يتعلم منهم كل طلاب العلم وانا أول هؤلاء الطلاب وفى مقدمتهم ولا نظن بكم الا كل الخيــــــر

بل أنا من يسعده ذلك بل واتشوق الى ذلك فكما تعلم أنت ملهمى ودائما تكمل ما ينقص أفكارى

طيب اولا شكرا على افكارك يا استاذ فؤش افندى وسعيد جدا جدا جدا بمشاركة حضرتك ثانيا اعتذر ان المشاركة أتت بعدك ولكن انا تقريبا بدأت كتابة المشاركة وتعديل الكود بالتطويرات الجديده تقريبا من الساعه 11: 45 تقريبا ولو لاحظت هتلاقينى ذكرت فى المشاركة فطبعا اعتذر ان جائت المشاركة بعد مشاركتك دون الاشارة اليكم فيها انت وضعت المشاركه وانا منشغل فى التنسيق وتطوير الكود وتعديل المشاركة اثناء تطوير الكود والرد والمشاركة فى نفس الوقت على موضع أخر فى المنتدى فى نفس الوقت وطبعا لو اردنا النتائج فى مرفقى المتواضع تظهر بشكل مباشر مع تغيير السجلات يمكن فقط ان يكون الكود التالى فى حدث الحالى للنموذج Private Sub Form_Current() Call btnCalculateGetInfo_Click End Sub حتى ولو كان مصدر بيانات النموذج هو الجدول مباشرة دون الاعتماد على الاستعلام كما قدمته انا كما فى هذا المرفق الاخيــــــــــــــــــــــر * ملاحظة انا عدلت الكود لتمرير اسم مربع النص كعنصر تحكم فى هذا المرفق بدلا من تمريره كنص سلسلة نصية تمت التوصيه من وجهة نظرى المتواضعة بهذا الكود النهائى فى هذا المرفق الشامل والوافى الاكواد النهائية بعد التطوير فى الوحده النمطية لحساب سن التقاعد Option Compare Database Option Explicit '------------------------------------------------------------ ' وحدة لحساب سن التقاعد والوقت المتبقي حتى التقاعد ' تحتوي على دالتين رئيسيتين: ' 1. GetRetirementInfo: لحساب تفاصيل التقاعد وإرجاعها كسلسلة نصية ' 2. PopulateRetirementFields: لتوزيع النتائج على مربعات نصوص في نموذج '------------------------------------------------------------ ' دالة لحساب تفاصيل التقاعد بناءً على تاريخ الميلاد ' الغرض: تحديد سن التقاعد، تاريخ التقاعد، والوقت المتبقي (سنوات، أشهر، أيام) ' المعاملات: ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' - showDetails (Boolean, اختياري): إذا كان True، يتم إرجاع التفاصيل الكاملة، وإذا كان False يتم إرجاع تاريخ التقاعد فقط ' الإرجاع: سلسلة نصية تحتوي على نتائج الحسابات أو رسالة خطأ إذا كان المدخل غير صالح Public Function GetRetirementInfo(birthDate As Variant, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer ' متغير لتخزين سن التقاعد Dim RetirementDate As Date ' متغير لتخزين تاريخ التقاعد Dim remainingYears As Integer ' متغير لتخزين السنوات المتبقية حتى التقاعد Dim remainingMonths As Integer ' متغير لتخزين الأشهر المتبقية حتى التقاعد Dim remainingDays As Integer ' متغير لتخزين الأيام المتبقية حتى التقاعد Dim result As String ' متغير لتخزين النتيجة النهائية كسلسلة نصية Dim currentDate As Date ' متغير لتخزين التاريخ الحالي Dim tempDate As Date ' متغير مؤقت للمساعدة في الحسابات التدريجية ' التحقق من صحة تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "" ' إرجاع رسالة خطأ إذا كان التاريخ فارغًا أو غير صالح Else birthDate = CDate(birthDate) ' تحويل المدخل إلى تاريخ ' تحديد سن التقاعد بناءً على تاريخ الميلاد وفقًا للقواعد المحددة If birthDate < DateSerial(1971, 7, 1) Then retirementAge = 60 ElseIf birthDate < DateSerial(1972, 7, 1) Then retirementAge = 61 ElseIf birthDate < DateSerial(1973, 7, 1) Then retirementAge = 62 ElseIf birthDate < DateSerial(1974, 7, 1) Then retirementAge = 63 ElseIf birthDate < DateSerial(1975, 7, 1) Then retirementAge = 64 Else retirementAge = 65 End If ' حساب تاريخ التقاعد بإضافة سن التقاعد إلى تاريخ الميلاد RetirementDate = DateAdd("yyyy", retirementAge, birthDate) ' إذا تم طلب التفاصيل الكاملة If showDetails Then currentDate = Date ' تعيين التاريخ الحالي ' حساب السنوات المتبقية باستخدام الفرق بين التاريخ الحالي وتاريخ التقاعد remainingYears = DateDiff("yyyy", currentDate, RetirementDate) tempDate = DateAdd("yyyy", remainingYears, currentDate) ' تصحيح السنوات إذا تجاوز التاريخ المؤقت تاريخ التقاعد If tempDate > RetirementDate Then remainingYears = remainingYears - 1 tempDate = DateAdd("yyyy", remainingYears, currentDate) End If ' حساب الأشهر المتبقية تدريجيًا remainingMonths = 0 While DateAdd("m", 1, tempDate) <= RetirementDate remainingMonths = remainingMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام المتبقية باستخدام الفرق بين التاريخ المؤقت وتاريخ التقاعد remainingDays = DateDiff("d", tempDate, RetirementDate) ' تجميع النتيجة كسلسلة نصية تحتوي على جميع التفاصيل result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & RetirementDate & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else ' إرجاع تاريخ التقاعد فقط إذا لم يتم طلب التفاصيل result = "تاريخ التقاعد: " & RetirementDate End If End If GetRetirementInfo = result ' إرجاع النتيجة النهائية End Function ' إجراء لتوزيع تفاصيل التقاعد على مربعات نصوص في نموذج ' الغرض: أخذ نتائج GetRetirementInfo وتعيينها في مربعات نصوص منفصلة أو مربع نص واحد ' المعاملات: ' - frm (Form): النموذج الذي يحتوي على مربعات النصوص ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' - txtBirthDate, txtRetirementAge, txtRetirementDate, txtRemainingYears, ' txtRemainingMonths, txtRemainingDays (TextBox, اختياري): كائنات مربعات النصوص للقيم المنفصلة ' - txtAllDetails (TextBox, اختياري): كائن مربع النص لعرض السلسلة الكاملة Public Sub PopulateRetirementFields(frm As Form, birthDate As Variant, _ Optional txtBirthDate As TextBox, Optional txtRetirementAge As TextBox, _ Optional txtRetirementDate As TextBox, Optional txtRemainingYears As TextBox, _ Optional txtRemainingMonths As TextBox, Optional txtRemainingDays As TextBox, _ Optional txtAllDetails As TextBox) Dim result As String ' متغير لتخزين النتيجة من GetRetirementInfo Dim lines() As String ' مصفوفة لتقسيم السلسلة إلى أسطر Dim i As Integer ' متغير للحلقة ' تفريغ جميع مربعات النصوص الممررة أولاً On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If Not txtAllDetails Is Nothing Then txtAllDetails.Value = "" If Not txtBirthDate Is Nothing Then txtBirthDate.Value = "" If Not txtRetirementAge Is Nothing Then txtRetirementAge.Value = "" If Not txtRetirementDate Is Nothing Then txtRetirementDate.Value = "" If Not txtRemainingYears Is Nothing Then txtRemainingYears.Value = "" If Not txtRemainingMonths Is Nothing Then txtRemainingMonths.Value = "" If Not txtRemainingDays Is Nothing Then txtRemainingDays.Value = "" On Error GoTo 0 ' التحقق من تاريخ الميلاد ومعالجته فقط إذا كان صالحًا If Not IsNull(birthDate) And IsDate(birthDate) Then ' استدعاء دالة GetRetirementInfo مع طلب التفاصيل الكاملة result = GetRetirementInfo(birthDate, True) ' التحقق مما إذا كانت النتيجة تحتوي على خطأ If result = "يرجى إدخال تاريخ ميلاد صالح" Then ' إذا كان هناك خطأ، تبقى الحقول فارغة (تم تفريغها مسبقًا) Else ' إذا تم تمرير txtAllDetails، اعرض السلسلة الكاملة فيه If Not txtAllDetails Is Nothing Then txtAllDetails.Value = result End If ' تقسيم السلسلة إلى أسطر لتعيين القيم في مربعات النصوص المنفصلة lines = Split(result, vbCrLf) For i = LBound(lines) To UBound(lines) On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If InStr(lines(i), "تاريخ الميلاد: ") > 0 And Not txtBirthDate Is Nothing Then txtBirthDate.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "سن التقاعد: ") > 0 And Not txtRetirementAge Is Nothing Then txtRetirementAge.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "تاريخ التقاعد: ") > 0 And Not txtRetirementDate Is Nothing Then txtRetirementDate.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "السنوات المتبقية: ") > 0 And Not txtRemainingYears Is Nothing Then txtRemainingYears.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأشهر المتبقية: ") > 0 And Not txtRemainingMonths Is Nothing Then txtRemainingMonths.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأيام المتبقية: ") > 0 And Not txtRemainingDays Is Nothing Then txtRemainingDays.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) End If On Error GoTo 0 Next i End If End If End Sub ' إجراء لعرض تعليمات حول استخدام وحدة سن التقاعد ' الغرض: تقديم إرشادات بسيطة للمستخدم حول كيفية استخدام الدوال Public Sub ShowRetirementHelp() Dim helpMessage As String helpMessage = "تعليمات استخدام وحدة سن التقاعد:" & vbCrLf & vbCrLf & _ "1. GetRetirementInfo(birthDate, [showDetails]):" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب، مثال: '2/19/1980')" & vbCrLf & _ " - showDetails: اختياري (True للحصول على التفاصيل الكاملة، False لتاريخ التقاعد فقط)" & vbCrLf & _ " - الإرجاع: سلسلة نصية تحتوي على تاريخ التقاعد أو التفاصيل الكاملة" & vbCrLf & vbCrLf & _ "2. PopulateRetirementFields(frm, birthDate, [txtBirthDate], [txtRetirementAge], " & _ "[txtRetirementDate], [txtRemainingYears], [txtRemainingMonths], [txtRemainingDays], [txtAllDetails]):" & vbCrLf & _ " - frm: النموذج الحالي (مطلوب)" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب)" & vbCrLf & _ " - txtBirthDate إلخ: كائنات مربعات النصوص لعرض القيم المنفصلة (اختياري، مثال: Me.txtBirth)" & vbCrLf & _ " - txtAllDetails: كائن مربع النص لعرض السلسلة الكاملة (اختياري، مثال: Me.txtRetirementDetails)" & vbCrLf & _ " - مثال: PopulateRetirementFields Me, Me.TEmp_BirthDate, Me.txtBirth, Me.txtRetAge, Me.txtRetirement, " & _ "Me.txtYearsLeft, Me.txtMonthsLeft, Me.txtDaysLeft, Me.txtRetirementDetails" & vbCrLf & vbCrLf & _ "ملاحظات: إذا لم يتم تمرير كائن مربع نص، يتم تجاهله دون إيقاف التنفيذ." MsgBox helpMessage, vbInformation, "تعليمات وحدة سن التقاعد" End Sub الاكواد النهائية بعد التطوير فى الوحده النمطية لحساب العمر Option Compare Database Option Explicit '------------------------------------------------------------ ' وحدة لحساب العمر بدقة بناءً على تاريخ الميلاد ' تحتوي على دالتين رئيسيتين: ' 1. GetAgeInfo: لحساب العمر (سنوات، أشهر، أيام) وإرجاعه كسلسلة نصية ' 2. PopulateAgeFields: لتوزيع النتائج على مربعات نصوص في نموذج '------------------------------------------------------------ ' دالة لحساب العمر بدقة بناءً على تاريخ الميلاد ' الغرض: تحديد العمر بالسنوات والأشهر والأيام من تاريخ الميلاد إلى التاريخ الحالي ' المعاملات: ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' الإرجاع: سلسلة نصية تحتوي على العمر أو رسالة خطأ إذا كان المدخل غير صالح Public Function GetAgeInfo(birthDate As Variant) As String Dim ageYears As Integer ' متغير لتخزين عدد السنوات في العمر Dim ageMonths As Integer ' متغير لتخزين عدد الأشهر في العمر Dim ageDays As Integer ' متغير لتخزين عدد الأيام في العمر Dim currentDate As Date ' متغير لتخزين التاريخ الحالي Dim tempDate As Date ' متغير مؤقت للمساعدة في الحسابات التدريجية Dim result As String ' متغير لتخزين النتيجة النهائية كسلسلة نصية ' التحقق من صحة تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" ' إرجاع رسالة خطأ إذا كان التاريخ فارغًا أو غير صالح Else birthDate = CDate(birthDate) ' تحويل المدخل إلى تاريخ currentDate = Date ' تعيين التاريخ الحالي ' التأكد من أن تاريخ الميلاد قبل التاريخ الحالي If birthDate > currentDate Then result = "تاريخ الميلاد يجب أن يكون قبل التاريخ الحالي" ' رسالة خطأ إذا كان التاريخ مستقبليًا Else ' حساب السنوات باستخدام الفرق بين تاريخ الميلاد والتاريخ الحالي ageYears = DateDiff("yyyy", birthDate, currentDate) tempDate = DateAdd("yyyy", ageYears, birthDate) ' تصحيح السنوات إذا تجاوز التاريخ المؤقت التاريخ الحالي If tempDate > currentDate Then ageYears = ageYears - 1 tempDate = DateAdd("yyyy", ageYears, birthDate) End If ' حساب الأشهر تدريجيًا ageMonths = 0 While DateAdd("m", 1, tempDate) <= currentDate ageMonths = ageMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام باستخدام الفرق بين التاريخ المؤقت والتاريخ الحالي ageDays = DateDiff("d", tempDate, currentDate) ' تجميع النتيجة كسلسلة نصية تحتوي على تفاصيل العمر result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "السنوات: " & ageYears & vbCrLf & _ "الأشهر: " & ageMonths & vbCrLf & _ "الأيام: " & ageDays End If End If GetAgeInfo = result ' إرجاع النتيجة النهائية End Function ' إجراء لتوزيع تفاصيل العمر على مربعات نصوص في نموذج ' الغرض: أخذ نتائج GetAgeInfo وتعيينها في مربعات نصوص منفصلة ' المعاملات: ' - frm (Form): النموذج الذي يحتوي على مربعات النصوص ' - birthDate (Variant): تاريخ الميلاد (مطلوب) ' - txtYears, txtMonths, txtDays (TextBox, اختياري): كائنات مربعات النصوص للسنوات والأشهر والأيام Public Sub PopulateAgeFields(frm As Form, birthDate As Variant, _ Optional txtYears As TextBox, Optional txtMonths As TextBox, _ Optional txtDays As TextBox) Dim result As String ' متغير لتخزين النتيجة من GetAgeInfo Dim lines() As String ' مصفوفة لتقسيم السلسلة إلى أسطر Dim i As Integer ' متغير للحلقة ' تفريغ جميع مربعات النصوص الممررة أولاً On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If Not txtYears Is Nothing Then txtYears.Value = "" If Not txtMonths Is Nothing Then txtMonths.Value = "" If Not txtDays Is Nothing Then txtDays.Value = "" On Error GoTo 0 ' التحقق من تاريخ الميلاد ومعالجته فقط إذا كان صالحًا If Not IsNull(birthDate) And IsDate(birthDate) Then ' استدعاء دالة GetAgeInfo لحساب العمر result = GetAgeInfo(birthDate) ' التحقق مما إذا كانت النتيجة تحتوي على خطأ If InStr(result, "يرجى إدخال تاريخ ميلاد صالح") > 0 Or InStr(result, "تاريخ الميلاد يجب أن يكون قبل التاريخ الحالي") > 0 Then ' إذا كان هناك خطأ، تبقى الحقول فارغة (تم تفريغها مسبقًا) Else ' تقسيم السلسلة إلى أسطر لتعيين القيم في مربعات النصوص lines = Split(result, vbCrLf) ' تعيين القيم لمربعات النصوص بناءً على الكائنات الممررة For i = LBound(lines) To UBound(lines) On Error Resume Next ' تجاهل الأخطاء إذا لم يتم تمرير المربع If InStr(lines(i), "السنوات: ") > 0 And Not txtYears Is Nothing Then txtYears.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأشهر: ") > 0 And Not txtMonths Is Nothing Then txtMonths.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأيام: ") > 0 And Not txtDays Is Nothing Then txtDays.Value = Mid(lines(i), InStr(lines(i), ": ") + 2) End If On Error GoTo 0 Next i End If End If End Sub ' إجراء لعرض تعليمات حول استخدام وحدة حساب العمر ' الغرض: تقديم إرشادات بسيطة للمستخدم حول كيفية استخدام الدوال Public Sub ShowAgeHelp() Dim helpMessage As String helpMessage = "تعليمات استخدام وحدة حساب العمر:" & vbCrLf & vbCrLf & _ "1. GetAgeInfo(birthDate):" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب، مثال: '2/19/1980')" & vbCrLf & _ " - الإرجاع: سلسلة نصية تحتوي على العمر (سنوات، أشهر، أيام)" & vbCrLf & vbCrLf & _ "2. PopulateAgeFields(frm, birthDate, [txtYears], [txtMonths], [txtDays]):" & vbCrLf & _ " - frm: النموذج الحالي (مطلوب)" & vbCrLf & _ " - birthDate: تاريخ الميلاد (مطلوب)" & vbCrLf & _ " - txtYears, txtMonths, txtDays: كائنات مربعات النصوص للسنوات والأشهر والأيام (اختياري، مثال: Me.txtAgeYears)" & vbCrLf & _ " - مثال: PopulateAgeFields Me, Me.TEmp_BirthDate, Me.txtAgeYears, Me.txtAgeMonths, Me.txtAgeDays" & vbCrLf & vbCrLf & _ "ملاحظات: إذا لم يتم تمرير كائن مربع نص، يتم تجاهله دون إيقاف التنفيذ." MsgBox helpMessage, vbInformation, "تعليمات وحدة حساب العمر" End Sub الاكواد داخل النموذج Option Compare Database Option Explicit Private Sub GetFullInfoByBirthDate() ' تفريغ جميع الحقول غير المرتبطة في كل مرة يتم تحميل سجل جديد On Error Resume Next ' تجاهل الأخطاء إذا كان أي مربع غير موجود Me.txtBirth.Value = "" Me.txtRetAge.Value = "" Me.txtRetirement.Value = "" Me.txtYearsLeft.Value = "" Me.txtMonthsLeft.Value = "" Me.txtDaysLeft.Value = "" Me.txtRetirementDetails.Value = "" Me.txtAgeYears.Value = "" Me.txtAgeMonths.Value = "" Me.txtAgeDays.Value = "" On Error GoTo 0 ' التحقق من وجود تاريخ ميلاد صالح قبل استدعاء الدوال If Not IsNull(Me.TEmp_BirthDate) And IsDate(Me.TEmp_BirthDate) Then ' استدعاء الدالة العامة الخاصة بالتقاعد مع تمرير النموذج وأسماء مربعات النصوص PopulateRetirementFields Me, Me.TEmp_BirthDate, , Me.txtRetAge, Me.txtRetirement, Me.txtYearsLeft, Me.txtMonthsLeft, Me.txtDaysLeft, Me.txtRetirementDetails PopulateAgeFields Me, Me.TEmp_BirthDate, Me.txtAgeYears, Me.txtAgeMonths, Me.txtAgeDays End If End Sub Private Sub Form_Current() GetFullInfoByBirthDate End Sub Private Sub TEmp_BirthDate_AfterUpdate() GetFullInfoByBirthDate End Sub Private Sub btnShowRetirementHelp_Click() ShowRetirementHelp End Sub Private Sub btnShowAgeHelp_Click() ShowAgeHelp End Sub سن التقاعد (5).accdb

طيب انا بالفعل فى محاولتي الاولي استخدمت الاستعلام بالشكل التالي وزي ما حضرتك تفضلت تماما باستخدام أسلوب IIf SELECT tbl_Employees.Emp_Code, tbl_Employees.Emp_Name, tbl_Employees.Emp_BirthDate, IIf(IsNull([Emp_BirthDate]),Null,DateAdd("yyyy",Switch([Emp_BirthDate]<DateSerial(1971,7,1),60,[Emp_BirthDate]<DateSerial(1972,7,1),61,[Emp_BirthDate]<DateSerial(1973,7,1),62,[Emp_BirthDate]<DateSerial(1974,7,1),63,[Emp_BirthDate]<DateSerial(1975,7,1),64,True,65),[Emp_BirthDate])) AS RetirementDate, Switch([Emp_BirthDate]<DateSerial(1971,7,1),60,[Emp_BirthDate]<DateSerial(1972,7,1),61,[Emp_BirthDate]<DateSerial(1973,7,1),62,[Emp_BirthDate]<DateSerial(1974,7,1),63,[Emp_BirthDate]<DateSerial(1975,7,1),64,True,65) AS RetirementAge, IIf(IsNull([RetirementDate]) Or [RetirementDate]<Date(),0,IIf(DateAdd("yyyy",DateDiff("yyyy",Date(),[RetirementDate]),Date())>[RetirementDate],DateDiff("yyyy",Date(),[RetirementDate])-1,DateDiff("yyyy",Date(),[RetirementDate]))) AS RemainingYears, IIf(IsNull([RetirementDate]) Or [RetirementDate]<Date(),0,DateDiff("m",DateAdd("yyyy",[RemainingYears],Date()),[RetirementDate])) AS RemainingMonths, IIf(IsNull([RetirementDate]) Or [RetirementDate]<Date(),0,Abs(DateDiff("d",DateAdd("m",[RemainingMonths],DateAdd("yyyy",[RemainingYears],Date())),[RetirementDate]))) AS RemainingDays, Year([RetirementDate]) AS RetirementYear FROM tbl_Employees WHERE (((Year(IIf(IsNull([Emp_BirthDate]),Null,DateAdd("yyyy",Switch([Emp_BirthDate]<DateSerial(1971,7,1),60,[Emp_BirthDate]<DateSerial(1972,7,1),61,[Emp_BirthDate]<DateSerial(1973,7,1),62,[Emp_BirthDate]<DateSerial(1974,7,1),63,[Emp_BirthDate]<DateSerial(1975,7,1),64,True,65),[Emp_BirthDate]))))>=Year(Date()))) ORDER BY tbl_Employees.Emp_Code, Year(IIf(IsNull([Emp_BirthDate]),Null,DateAdd("yyyy",Switch([Emp_BirthDate]<DateSerial(1971,7,1),60,[Emp_BirthDate]<DateSerial(1972,7,1),61,[Emp_BirthDate]<DateSerial(1973,7,1),62,[Emp_BirthDate]<DateSerial(1974,7,1),63,[Emp_BirthDate]<DateSerial(1975,7,1),64,True,65),[Emp_BirthDate]))); ولكن ولكن ولكن لو قمت بعمل و عرض الاستعلام المباشر السابق مع المثال المرفق وقارنته بالاستعلام الاساسي والذى يعتمد على الكود سوف تجد هناك فروقات وتباين في القيم يا نهار ابيض فروقات ايه الارتباك ده و مين صح و نختار مين وليه حصل فروقات وتباين وعلشان كده انا كتتب الكود ولم اشارك الاستعلام الموجود هنا اساسا فى تقديم الحل تعالي نعرف السبب اولا الكود يوفر لمطور النظم التعديل والتطوير فى أي وقت عن الاستعلام بشكل اكثر سهولة ومرونه ده بغض النظر عن سهولة وإمكانية استخدامه بشكل مرن وسهل فى زوايا التطبيق المختلفة حسب الرغبة ده عير ان الكود ممكن جدا وسهل استخدامه مع قاعدة بيانات مع اختلاف اسماء الجداول والحقول تخيل لو عجبك الاستعلام وتريد نقله الي قاعدتك سوف يكون الموضوع مرهق قليلا طيب ليه فى فروقات وايهم اصح وأدق أو أكثر دقه وليه استبعدت الاستعلام المباشر من الحل وده السبب الرئيسي والذي قد يغفل عنه الكثيــــر أو لا يعرف عنه البعض الكود VBA يحسب الأشهر تدريجيا باستخدام حلقة While مما يضمن عدم التجاوز الاستعلام يستخدم DateDiff("m", ...)، وهو يحسب عدد الأشهر بين تاريخين بغض النظر عن الأيام الدقيقة، مما يعطي تقديرا أعلى و تأثير ذلك بسبب زيادة الأشهر في الاستعلام، التاريخ المؤقت يصبح أبعد عن تاريخ التقاعد مما يؤدي إلى قيم مختلفة في RemainingDays مقارنة النتائج (مثال واحد): الموظف: 1001 (تجربة): تاريخ الميلاد: 2 مايو 1982 تاريخ التقاعد: 2 مايو 2047 التاريخ الحالي: 23 مارس 2025 (بناءً على تاريخ اليوم للمشاركة الحالية ) نتيجة الكود VBA: RemainingYears: 22 RemainingMonths: 1 RemainingDays: 9 نتيجة الاستعلام SQL: RemainingYears: 22 RemainingMonths: 2 RemainingDays: 21 النتيجة: الاستعلام أقل دقة في حساب الأشهر والأيام لأنه يعتمد علي DateDiff مباشرة بدلا من الحساب التدريجي لذلك الاعتماد علي الكود افضل وأكثر دقه من الاستعلام مباشرة وقطعا أكثر مرونه عند التعديل او التطوير او الاستخدام فى أماكن مختلفة شكرا على كلماتكم الطيبة جزاكم الله خيرا تم توضيح سبب أن الداله احترافيه فى السرد بعاليه طيب بالنسبة لهذه الجزئيه نقوم بإعادة تطوير المثال المرفق مرة أخرى تدلل اولا الكود الرئيسي لحساب سن التقاعد وكما أشرنا سابقا سوف يكون داخل وحده نمطيه باسم : basRetirementInfo بالشكل التالي كما هو ولن اعدله حتى يمكن استخدامه داخل اى استعلام Public Function GetRetirementInfo(birthDate As Variant, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer Dim RetirementDate As Date Dim remainingYears As Integer Dim remainingMonths As Integer Dim remainingDays As Integer Dim result As String Dim currentDate As Date Dim tempDate As Date ' التحقق من تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" Else birthDate = CDate(birthDate) ' تحديد سن التقاعد بناءً على تاريخ الميلاد If birthDate < DateSerial(1971, 7, 1) Then retirementAge = 60 ElseIf birthDate < DateSerial(1972, 7, 1) Then retirementAge = 61 ElseIf birthDate < DateSerial(1973, 7, 1) Then retirementAge = 62 ElseIf birthDate < DateSerial(1974, 7, 1) Then retirementAge = 63 ElseIf birthDate < DateSerial(1975, 7, 1) Then retirementAge = 64 Else retirementAge = 65 End If ' حساب تاريخ التقاعد RetirementDate = DateAdd("yyyy", retirementAge, birthDate) If showDetails Then currentDate = Date ' حساب السنوات المتبقية remainingYears = DateDiff("yyyy", currentDate, RetirementDate) tempDate = DateAdd("yyyy", remainingYears, currentDate) If tempDate > RetirementDate Then remainingYears = remainingYears - 1 tempDate = DateAdd("yyyy", remainingYears, currentDate) End If ' حساب الأشهر المتبقية remainingMonths = 0 While DateAdd("m", 1, tempDate) <= RetirementDate remainingMonths = remainingMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام المتبقية remainingDays = DateDiff("d", tempDate, RetirementDate) ' تجميع النتيجة result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & RetirementDate & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else result = "تاريخ التقاعد: " & RetirementDate End If End If GetRetirementInfo = result End Function الان سوف أقوم بعم داله مساعده للفصل والتوزيع : فى نفس الوحده النمطيه العامة Public Sub PopulateRetirementFields(frm As Form, birthDate As Variant, _ Optional txtBirthDateName As String = "", Optional txtRetirementAgeName As String = "", _ Optional txtRetirementDateName As String = "", Optional txtRemainingYearsName As String = "", _ Optional txtRemainingMonthsName As String = "", Optional txtRemainingDaysName As String = "") Dim result As String Dim lines() As String Dim i As Integer ' استدعاء الكود الأصلي مع التفاصيل result = GetRetirementInfo(birthDate, True) ' التحقق مما إذا كانت النتيجة تحتوي على خطأ If result = "يرجى إدخال تاريخ ميلاد صالح" Then If txtBirthDateName <> "" Then frm.Controls(txtBirthDateName) = result If txtRetirementAgeName <> "" Then frm.Controls(txtRetirementAgeName) = "" If txtRetirementDateName <> "" Then frm.Controls(txtRetirementDateName) = "" If txtRemainingYearsName <> "" Then frm.Controls(txtRemainingYearsName) = "" If txtRemainingMonthsName <> "" Then frm.Controls(txtRemainingMonthsName) = "" If txtRemainingDaysName <> "" Then frm.Controls(txtRemainingDaysName) = "" Else ' تقسيم السلسلة إلى أسطر lines = Split(result, vbCrLf) ' تعيين القيم لمربعات النصوص بناءً على الأسماء الممررة For i = LBound(lines) To UBound(lines) On Error Resume Next ' تجاهل الأخطاء إذا كان المربع غير موجود If InStr(lines(i), "تاريخ الميلاد: ") > 0 And txtBirthDateName <> "" Then frm.Controls(txtBirthDateName) = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "سن التقاعد: ") > 0 And txtRetirementAgeName <> "" Then frm.Controls(txtRetirementAgeName) = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "تاريخ التقاعد: ") > 0 And txtRetirementDateName <> "" Then frm.Controls(txtRetirementDateName) = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "السنوات المتبقية: ") > 0 And txtRemainingYearsName <> "" Then frm.Controls(txtRemainingYearsName) = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأشهر المتبقية: ") > 0 And txtRemainingMonthsName <> "" Then frm.Controls(txtRemainingMonthsName) = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأيام المتبقية: ") > 0 And txtRemainingDaysName <> "" Then frm.Controls(txtRemainingDaysName) = Mid(lines(i), InStr(lines(i), ": ") + 2) End If On Error GoTo 0 ' إعادة تعيين معالجة الأخطاء Next i End If End Sub ويتم استدعاء هذه الداله فقط بتمرير اسماء مربعات النص كما هي فى النموذج والتي سوف تسميها انت علي حسب اختياراتك وتمررها للكود حسب الاسماء التي سوف تستخدمها مثال الاستدعاء فى النموذج PopulateRetirementFields Me, Me.TEmp_BirthDate, "Birth", "RetAge", "Retirement", "YearsLeft", "MonthsLeft", "DaysLeft" طيب انا كتبت الداله بمرونه بحيث اعرض ما اريد عرضه فقط حسب تمرير المعاملات لنفترض انه لا اريد عمل مربع نص لتاريخ الميلاد مرة أخري علي اعتبار انه موجود اصلا في النموذج وبناء عليه تتم العمليه كلها اساسا في هذه الحالة نستدعي الداله بالشكل التالي تماما PopulateRetirementFields Me, Me.TEmp_BirthDate, "", "RetAge", "Retirement", "YearsLeft", "MonthsLeft", "DaysLeft" طيب وبنفس المنطق يمكن عمل داله حساب العمر بالشكل التالي فى وحده نمطيه عامة باسم : basAgeInfo الكود : Public Function GetAgeInfo(birthDate As Variant) As String Dim ageYears As Integer Dim ageMonths As Integer Dim ageDays As Integer Dim currentDate As Date Dim tempDate As Date Dim result As String ' التحقق من تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" Else birthDate = CDate(birthDate) currentDate = Date ' التأكد من أن تاريخ الميلاد قبل التاريخ الحالي If birthDate > currentDate Then result = "تاريخ الميلاد يجب أن يكون قبل التاريخ الحالي" Else ' حساب السنوات ageYears = DateDiff("yyyy", birthDate, currentDate) tempDate = DateAdd("yyyy", ageYears, birthDate) If tempDate > currentDate Then ageYears = ageYears - 1 tempDate = DateAdd("yyyy", ageYears, birthDate) End If ' حساب الأشهر ageMonths = 0 While DateAdd("m", 1, tempDate) <= currentDate ageMonths = ageMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام ageDays = DateDiff("d", tempDate, currentDate) ' تجميع النتيجة result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "السنوات: " & ageYears & vbCrLf & _ "الأشهر: " & ageMonths & vbCrLf & _ "الأيام: " & ageDays End If End If GetAgeInfo = result End Function للفصل والتوزيع : فى نفس الوحده النمطيه العامة الكود Public Sub PopulateAgeFields(frm As Form, birthDate As Variant, _ Optional txtYearsName As String = "", Optional txtMonthsName As String = "", _ Optional txtDaysName As String = "") Dim result As String Dim lines() As String Dim i As Integer ' استدعاء دالة حساب العمر result = GetAgeInfo(birthDate) ' التحقق مما إذا كانت النتيجة تحتوي على خطأ If InStr(result, "يرجى إدخال تاريخ ميلاد صالح") > 0 Or InStr(result, "تاريخ الميلاد يجب أن يكون قبل التاريخ الحالي") > 0 Then If txtYearsName <> "" Then frm.Controls(txtYearsName) = "" If txtMonthsName <> "" Then frm.Controls(txtMonthsName) = "" If txtDaysName <> "" Then frm.Controls(txtDaysName) = "" Else ' تقسيم السلسلة إلى أسطر lines = Split(result, vbCrLf) ' تعيين القيم لمربعات النصوص بناءً على الأسماء الممررة For i = LBound(lines) To UBound(lines) On Error Resume Next ' تجاهل الأخطاء إذا كان المربع غير موجود If InStr(lines(i), "السنوات: ") > 0 And txtYearsName <> "" Then frm.Controls(txtYearsName) = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأشهر: ") > 0 And txtMonthsName <> "" Then frm.Controls(txtMonthsName) = Mid(lines(i), InStr(lines(i), ": ") + 2) ElseIf InStr(lines(i), "الأيام: ") > 0 And txtDaysName <> "" Then frm.Controls(txtDaysName) = Mid(lines(i), InStr(lines(i), ": ") + 2) End If On Error GoTo 0 ' إعادة تعيين معالجة الأخطاء Next i End If End Sub ويتم الاستدعاء بنفس المنطق السابق لدله التقاعد بالشكل التالى : PopulateAgeFields Me, Me.TEmp_BirthDate, "txtAgeYears", "txtAgeMonths", "txtAgeDays" طيب لو افترضنا انه نريد العمر بعددد السنوات فقط يكون الاستدعاء PopulateAgeFields Me, Me.TEmp_BirthDate, "txtAgeYears", "", "" أو PopulateAgeFields Me, Me.TEmp_BirthDate, "txtAgeYears" ملاحظة : المرفق يحتوى على الاستعلام : qryRetirementInfo يعتمد على الداله الرئيسيه لحساب سن التقاعد فى الكود الاستعلام : Query1 يحسب سن التقاعد بشكل مباشر بدون التقيد بضوابط الحساب تبعا للقانون يعتمد على العام فقط بدون الشهر وطبعا ده غير صحيح الاستعلام : Query2 يحسب سن التقاعد بشكل مباشر مع التقيد بضوابط الحساب تبعا للقانون و يعتمد على الشهر و العام - وطبعا ده غير دقيق وأخيـــــــــــــــرا المرفق سن التقاعد (4).accdb

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

طبعا مما لاشك فيه لابد للطالب من الاستئذان توقيرا واجلا للمعلم القدير الجليل حاسس انى اتدبست - او غلطت فى شئ - أو يتم اختبارى وأنا أقلق من هذه الموافق جدا ولكن سوف ادلى بدلوي فإن اخطأت فهذا مني ومن سوء فهمي وتقديري أنا و وقتها تصحون لي خطئي وجزاكم الله عني كل خير وإن أصبت فلقد تعلمت على ايديكم فأنتم أحد الأساتذة العظماء الذين أدين لهم بالفضل بعد رب العزة سبحانه وتعالي سؤالك جدا ممتاز يا أستاذي ويفتح مجالا لفهم أعمق لدالتي Nz وTrim خاصة في سياق التحقق من الحقول الفارغة دعني أوضح حسب فهمى المتواضح الفائدة من استخدام هاتين الدالتين ومتى تكونان ضرورييتان و ما الفرق بين استخدامهما أو عدمهما مع مثال أولا شرح الدالتين: 1- دالة Nz : Nz(Value, ValueIfNull) تستخدم لتحويل قيمة Null إلى قيمة أخرى محددة (مثل "" أو 0 حسب رغبة مطور النظم ) مفيدة جدا عندما تتعامل مع حقل قد يحتوي على Null لأن أي عملية مقارنة مع Null (مثل Null = "") ترجع Null وليس True أو False 2- دالة Trim : Trim(Value) تزيل المسافات البيضاء (Whitespace) من بداية و نهاية السلسلة النصية مثل " abs " أو " abs" أو "abs " تصبح "abc" لا تتعامل مع Null فإذا كانت القيمة هى Null فإن Trim(Null) يظل Null الهدف: تريد التحقق مما إذا كان الحقل (Me.yyy) "فارغا" أم لا "فارغ" قد يعني: Null (لا قيمة على الإطلاق) "" (سلسلة فارغة). " " أو " " (مسافات فقط) ** إذا كان الحقل فارغا بأي من هذه الحالات يتحقق الشرط و إذا كان يحتوي على قيمة فعلية (مثل "abc") لا يتحقق الشرط. سؤال حضرتك : هل استخدام Nz و Trim يضيف ميزة إضافية في هذا السياق أم أن التحقق الأساسي بـ IsNull و = "" كاف؟ 1- بدون Nz و Trim: If Me.xxx <> 0 And (IsNull(Me.yyy) Or Me.yyy = "") Then ' الشرط تحقق Else End If يتحقق الشرط إذا: Me.yyy هو Null Me.yyy هو "" (سلسلة فارغة) لا يتحقق الشرط إذا: Me.yyy يحتوي على مسافات فقط (مثل " " أو " ")، لأن " " <> "" Me.yyy يحتوي على نص (مثل "abc")، وهذا متوقع 2- مع Nz و Trim: If Me.xxx <> 0 And (IsNull(Me.yyy) Or Trim(Nz(Me.yyy, "")) = "") Then ' الشرط تحقق Else End If يتحقق الشرط إذا: Me.yyy هو Null (لأن Nz يحوله إلى "" و Trim("") = "") Me.yyy هو "" (لأن Trim("") = "") Me.yyy هو " " أو " " (لأن Trim(" ") = "") لا يتحقق الشرط إذا: Me.yyy يحتوي على نص فعلي (مثل "abc")، لأن Trim("abc") <> "" الميزة الإضافية لـ Nz و Trim: Nz: يضمن التعامل مع Null بطريقة آمنة مما يمنع أي أخطاء غير متوقعة إذا حاولت مقارنة Null مباشرة في الكود بدون Nz الشرط IsNull(Me.yyy) كاف لكن استخدام Nz يجعل الكود أكثر مرونة إذا أردت لاحقا إجراء عمليات إضافية على القيمة Trim: يضيف القدرة على اعتبار المسافات البيضاء (Whitespace) كقيمة "فارغة" بدون Trim إذا كان Me.yyy = " " »--»» فإن الشرط لن يتحقق لأن " " <> "" الفرق الأساسي: بدون Trim و Nz: لا يعتبر المسافات فقط (" ") فارغة مع Trim و Nz: يعتبر المسافات فقط فارغة بالإضافة إلى Null و "" الأمثلة العملبة : 1- الكود بدون Nz و Trim Me.xxx = 5 , Me.yyy = Null → "الشرط تحقق" Me.xxx = 5 , Me.yyy = "" → "الشرط تحقق" Me.xxx = 5 , Me.yyy = " " → "الشرط لم يتحقق" (لأن " " <> "") "Me.xxx = 5 , Me.yyy = "abc → "الشرط لم يتحقق" 2- الكود مع Nz و Trim Me.xxx = 5 , Me.yyy = Null → "الشرط تحقق" Me.xxx = 5 , Me.yyy = "" → "الشرط تحقق" Me.xxx = 5 , Me.yyy = " " → "الشرط تحقق" (لأن Trim(" ") = "") "Me.xxx = 5 , Me.yyy = "abc → "الشرط لم يتحقق" الخلاصة: إذا كان مطور النظم لا يهتم بالمسافات (مثل " " ) ويتعتبرها قيمة غير فارغة فالكود الأبسط بدون Nz و Trim كاف إذا كان مطور النظم يريد أن تعتبر المسافات فارغة (مثل " " ) فاستخدام Trim و Nz يعطي ميزة إضافية إذا نستخلص مما سبق أن Trim و Nz يجعلان الكود أكثر شمولية للتعامل مع جميع حالات "الفراغ" ( Null , سلسلة فارغة , مسافات فقط ) مما يجعله أكثر مرونة إذا كانت البيانات غير متسقة أو تحتوي على إدخالات غير متوقعة مثل المسافات

و مشاركه مع استاذى القدير و معلمى الجليل الاستاذ @ابو عارف وطبعا بعد إذنه اضافة بسيطه If Me.xxx <> 0 And (IsNull(Me.yyy) Or Trim(Nz(Me.yyy, "")) = "") Then ' هنا نكتب الحدث Else End If Nz(Me.yyy, ""): يحول Null إلى "" Trim(...) = "": يتحقق إذا كانت النتيجة بعد إزالة المسافات فارغة مما يغطي Null , "" , " "

طيب الحل فى المشاركة السابقة كنت قمت به اجتهادا قبل فترة من الزمن ولكن لم اكن على دراية كاملة بالتفاصيل آنذاك وذلك كان فى بداية الشروع لسن هذا القانون و بكل صراحة انا وضعت الحل اولا قبل محاولة فتح الاكسل اصلا بناء على دراية سابقة ولكن استوقفتنى هذه الجملة عند مراجعتى للموضوع بعد نشر الحل الاول بالمشاركة السابقة و بعد فتح الاكسل وبعد وضع الحل فى المشاركة وبالاخص بعد كســر الحماية عن ملف الاكسل وبعد التركيز اكتشفت انه هناك شرط أخر ايضا ليس فقط عام الميلاد المستخرج من تاريخ الميلاد ولكن العام مع الشهر وبعد البحث على الانترنت وعن القانون الذى لم أكن اعرف رقمه حصلت على التالى * ملاحظة هامة : الجدول السابق لا يوضح صراحة سن التقاعد للمواليد قبل 1 يوليو 1971 لذلك سوف أفترض أنهم يخرجون على المعاش في سن 60 عاما وهو السن التقليدي قبل تطبيق الزيادة التدريجية لذلك سوف أقوم ببعض التعديلات للتناسب مع كل الشروط السابقة الكود الجديد Public Function GetRetirementInfo(birthDate As Variant, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer Dim retirementDate As Date Dim remainingYears As Integer Dim remainingMonths As Integer Dim remainingDays As Integer Dim result As String Dim currentDate As Date Dim tempDate As Date ' التحقق من تاريخ الميلاد If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" Else birthDate = CDate(birthDate) ' تحديد سن التقاعد بناءً على تاريخ الميلاد If birthDate < DateSerial(1971, 7, 1) Then retirementAge = 60 ElseIf birthDate < DateSerial(1972, 7, 1) Then retirementAge = 61 ElseIf birthDate < DateSerial(1973, 7, 1) Then retirementAge = 62 ElseIf birthDate < DateSerial(1974, 7, 1) Then retirementAge = 63 ElseIf birthDate < DateSerial(1975, 7, 1) Then retirementAge = 64 Else retirementAge = 65 End If ' حساب تاريخ التقاعد retirementDate = DateAdd("yyyy", retirementAge, birthDate) If showDetails Then currentDate = Date ' حساب السنوات المتبقية remainingYears = DateDiff("yyyy", currentDate, retirementDate) tempDate = DateAdd("yyyy", remainingYears, currentDate) If tempDate > retirementDate Then remainingYears = remainingYears - 1 tempDate = DateAdd("yyyy", remainingYears, currentDate) End If ' حساب الأشهر المتبقية remainingMonths = 0 While DateAdd("m", 1, tempDate) <= retirementDate remainingMonths = remainingMonths + 1 tempDate = DateAdd("m", 1, tempDate) Wend ' حساب الأيام المتبقية remainingDays = DateDiff("d", tempDate, retirementDate) ' تجميع النتيجة result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & retirementDate & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else result = "تاريخ التقاعد: " & retirementDate End If End If GetRetirementInfo = result End Function و يتم استدعاء الكود بأحد الطريقتين تمام كما تم مع الكود السابق الاولى للحصول على تاريخ التقاعد فقط GetRetirementInfo([Emp_BirthDate]) الثانية : بيانات شاملة GetRetirementInfo([Emp_BirthDate],True) وبهذا تكون هذه القاعده الجديده بهذا الكود وفق المعايير الصحيحه طبقا للقانون وأخيرا المرفق سن التقاعد (3).accdb

اتفضل ده الكود فى الوحده النمطيه التى تحمل اسم : basRetirementInfo Option Compare Database Option Explicit Public Function GetRetirementInfo(birthDate As Variant, Optional showDetails As Boolean = False) As String Dim retirementAge As Integer Dim retirementDate As Date Dim remainingYears As Integer Dim remainingMonths As Integer Dim remainingDays As Integer Dim retirementYear As Integer Dim result As String ' التحقق من أن تاريخ الميلاد ليس فارغًا If IsNull(birthDate) Or Not IsDate(birthDate) Then result = "يرجى إدخال تاريخ ميلاد صالح" Else birthDate = CDate(birthDate) ' تحديد سن التقاعد بناءً على سنة الميلاد Select Case Year(birthDate) Case Is < 1972 retirementAge = 60 Case Is < 1974 retirementAge = 61 Case Is < 1976 retirementAge = 62 Case Is < 1978 retirementAge = 63 Case Is < 1980 retirementAge = 64 Case Else retirementAge = 65 End Select ' حساب تاريخ التقاعد retirementDate = DateAdd("yyyy", retirementAge, birthDate) retirementYear = Year(retirementDate) If showDetails Then ' حساب السنوات والأشهر والأيام المتبقية حتى التقاعد remainingYears = IIf(DateDiff("yyyy", Date, retirementDate) < 0, 0, DateDiff("yyyy", Date, retirementDate)) remainingMonths = IIf(DateDiff("m", Date, retirementDate) < 0, 0, DateDiff("m", Date, retirementDate)) remainingDays = IIf(DateDiff("d", Date, retirementDate) < 0, 0, DateDiff("d", Date, retirementDate)) ' إعداد النتيجة مع كل التفاصيل result = "تاريخ الميلاد: " & birthDate & vbCrLf & _ "سن التقاعد: " & retirementAge & vbCrLf & _ "تاريخ التقاعد: " & retirementDate & vbCrLf & _ "سنة التقاعد: " & retirementYear & vbCrLf & _ "السنوات المتبقية: " & remainingYears & vbCrLf & _ "الأشهر المتبقية: " & remainingMonths & vbCrLf & _ "الأيام المتبقية: " & remainingDays Else ' إعداد النتيجة لتاريخ التقاعد فقط result = retirementDate End If End If ' إرجاع النتيجة GetRetirementInfo = result End Function بيتم استدعاء الكود بأحد الطريقتين الاولى للحصول على تاريخ التقاعد فقط GetRetirementInfo([Emp_BirthDate]) الثانية : بيانات شاملة GetRetirementInfo([Emp_BirthDate],True) طبعا مفيش دلع اكتر من كده ... شغل فاخر من الاخر وطبعا انت جايب لنا ملف اكسل مقفول وده يا سيدى ملف الاكسل مفتوح حذفت لك الحمايه من عليه علشان تقدر تشوف المعادلات بس ركز علشان المعادلات ما تخرب منك بدون ما تشعر داخل الاكسل برنامج حساب سن المعاش 2.xlsx سن التقاعد 2.accdb

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

اثراء للموضوع دى داله معدله ومحدثه لـما يعرف بـ ShellWait أو Shell_n_Wait فى هذا الموضوع

السلام عليكم ورحمة الله وبركاته أشارك معكم اليوم وحدة نمطية متقدمة باسم basShellExecutor تهدف إلى توفير حلول مرنة وفعالة لتنفيذ الأوامر والملفات في بيئة Windows مع تحكم دقيق بالعمليات تم تصميم هذه الوحدة لتلبية احتياجات المطورين المختلفة والمتنوعة وتعرف او شائعه لدى المطورين باسم : ShellWait ولكن تم اعادة هيكلة وتطوير الوظائف بشكل احترافى لاضفاء أكبر قدر ممكن من الفاعليه والمرونة والكفائه وتعدد الاستخدمات ودعم تنوع الخيارات الممكنه بقدر الإمكان مميزات الكود المرونة: يدعم تنفيذ الأوامر بثلاث طرق (انتظار غير محدود , مهلة زمنية محددة , تنفيذ بسيط) مما يجعله متعدد الاستخدامات الاستجابة: يستخدم " DoEvents " لضمان استجابة واجهة المستخدم أثناء الانتظار مما يمنع تجمد التطبيق التحكم الدقيق: يتيح إنهاء الحلقات يدويا عبر متغير عام (g_TerminateLoops) ويمنع التداخل بين الاستدعاءات باستخدام (m_IsExecuting) التوافق: توافق تعريفات API مع أنظمة 32 بت و64 بت معالجة الأخطاء: يوفر معالجة أخطاء قوية مع رسائل واضحة لتسهيل التصحيح التنظيم: مقسم إلى أقسام واضحة (ثوابت , تعريفات , دوال) مع تعليقات عربية شاملة لتسهيل الصيانة والفهم وظيفة الكود تتيح وحدة basShellExecutor تشغيل الأوامر والملفات بثلاث طرق مختلفة مع القدرة على التحكم في وقت التنفيذ و معالجة الأحداث والتقاط النتائج الدوال الرئيسية هي: ExecuteAndWait: الغرض: تنفيذ أمر أو تشغيل ملف والانتظار حتى اكتماله مع استجابة مستمرة لواجهة المستخدم الاستخدام: مثالي للعمليات التي تحتاج إلى إكمال كامل قبل المتابعة (مثل فتح برنامج وانتظار إغلاقه) ExecuteWithTimeout: الغرض: تنفيذ أمر أو تشغيل ملف مع مهلة زمنية مع إمكانية إنهاء العملية إذا تجاوزت الحد الاستخدام: ممناسب للعمليات ذات الوقت المحدود أو التي قد تتوقف (مثل محاولة استخدام أدوات خارجية) ExecuteWScript: الغرض: تنفيذ أمر بسيط باستخدام " WScript.Shell " مع خيار الانتظار الاستخدام: مفيد للمهام السريعة دون تعقيد على سبيل المثال (مثل تشغيل أوامر CMD) ExecuteWScriptCapture (اختياري): الغرض: تنفيذ أمر والتقاط ناتجه النصي للاستخدام البرمجي الاستخدام: مثالي لتحليل نتائج الأوامر (مثل قوائم الملفات من " dir " ) اسم الوحدة النمطية العامة : basShellExecutor الكود : ' يضمن مقارنة النصوص بناءً على إعدادات قاعدة البيانات (مثل ترتيب الحروف واللغة) Option Compare Database ' يجبر على تعريف المتغيرات صراحة قبل استخدامها، مما يمنع الأخطاء الناتجة عن الأسماء الخاطئة Option Explicit '======================================================================================================================= '------ الثوابت Public Const PROCESS_TIMEOUT_INFINITE As Long = &HFFFFFFFF Public Const PROCESS_STILL_ACTIVE As Long = &H103 Public Const PROCESS_TERMINATED As Long = vbObjectError Or &HDEAD Public Const MAX_PATH_LENGTH As Long = 260 Public Const QS_ALL_INPUT As Long = &H4FF Private Const ERR_NO_COMMAND As Long = vbObjectError Or 1001 Private Const ERR_EXECUTING As Long = vbObjectError Or 1002 Private Const ERR_EXECUTION_FAILED As Long = vbObjectError Or 1003 Private Const ERR_TERMINATION_FAILED As Long = vbObjectError Or 1004 Private Const SHELL_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SHELL_MASK_DOENVSUBST As Long = &H200 Private Const SHELL_MASK_SUPPRESS_ERRORS As Long = &H400 Private Const PROCESS_QUERY_INFO As Long = &H400 Private Const PROCESS_SYNCHRONIZE As Long = &H100000 Private Const PROCESS_TERMINATE As Long = &H1 Private Const ERROR_ACCESS_DENIED As Long = 5 '======================================================================================================================= '------ التعدادات Public Enum ShellWindowStyle WindowHidden = 0 WindowNormal = 1 WindowMinimized = 2 WindowMaximized = 3 WindowNoActivate = 4 End Enum '======================================================================================================================= '------ الأنواع المخصصة #If VBA7 Then Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As LongPtr Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As LongPtr ItemListPointer As LongPtr ClassName As String ClassKeyHandle As LongPtr HotKey As Long IconHandle As LongPtr ProcessHandle As LongPtr End Type #Else Private Type ShellExecuteParams Size As Long Mask As Long ParentWindowHandle As Long Verb As String filePath As String Arguments As String WorkingDirectory As String ShowCommand As Long InstanceHandle As Long ItemListPointer As Long ClassName As String ClassKeyHandle As Long HotKey As Long IconHandle As Long ProcessHandle As Long End Type #End If '======================================================================================================================= '------ تعريفات API #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPtr ' فتح مقبض العملية Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long ' إغلاق مقبض العملية Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr ' إنشاء مؤقت قابل للانتظار Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long ' جلب معرف العملية Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long ' تبسيط المسار Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr ' استخراج المعاملات من المسار Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long ' تنفيذ أمر عبر Shell Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long ' إعادة تخصيص السلسلة Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) ' إزالة المعاملات من المسار Private Declare PtrSafe Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long ' فتح مقبض العملية Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long ' إغلاق مقبض العملية Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long ' توسيع متغيرات البيئة Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long ' جلب رمز الخروج للعملية Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long ' انتظار العمليات مع معالجة الأحداث Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long ' إعادة تخصيص حجم السلسلة Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long ' إنشاء مؤقت قابل للانتظار Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long ' جلب معرف العملية Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long ' تبسيط المسار Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long ' استخراج المعاملات من المسار Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long ' ضبط المؤقت Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long ' تنفيذ أمر عبر Shell Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long ' إعادة تخصيص السلسلة Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) ' إزالة المعاملات من المسار Private Declare Function TerminateProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long ' إنهاء العملية قسريًا Private Declare Function GetTickCount Lib "kernel32.dll" () As Long ' لقياس الوقت المنقضي #End If '======================================================================================================================= '------ المتغيرات العامة و الخاصة Public g_TerminateLoops As Boolean ' متغير للتحكم في إنهاء الحلقات يدويًا Private m_IsExecuting As Boolean ' علامة لمنع التداخل أثناء التنفيذ '======================================================================================================================= '------------------------------------------- الدوال العامة ' تشغيل أمر والانتظار حتى ينتهي مع استجابة الواجهة Public Function ExecuteAndWait(ByVal CommandLine As String, _ Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, _ Optional ByVal RunAsAdmin As Boolean = False, _ Optional ByVal MaxWaitMs As Long = PROCESS_TIMEOUT_INFINITE) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteAndWait", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ' توسيع متغيرات البيئة ExpandedPath = ExpandEnvVars(CommandLine) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteAndWait", "فشل في تنفيذ الأمر: " & CommandLine End If ProcessHandle = .ProcessHandle End With startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If MaxWaitMs <> PROCESS_TIMEOUT_INFINITE Then If (GetTickCount - startTime) > MaxWaitMs Then Debug.Print "تجاوز الحد الأقصى للانتظار: " & MaxWaitMs & " ميلي ثانية" Exit Do End If End If Loop ExecuteAndWait = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteAndWait", Err.Description End Function ' دالة لتنفيذ أمر مع مهلة زمنية اختيارية وخيار التشغيل كمسؤول Public Function ExecuteWithTimeout(Command As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal TimeoutMs As Long, Optional ByVal RunAsAdmin As Boolean = False, Optional RetryCount As Long = 0) As Long #If VBA7 Then Dim ShellParams As ShellExecuteParams Dim ProcessHandle As LongPtr #Else Dim ShellParams As ShellExecuteParams Dim ProcessHandle As Long #End If Dim ExpandedPath As String Dim Executable As String Dim Arguments As String Dim startTime As Long Dim ExitCode As Long Dim Result As Long Dim RetryIndex As Long If m_IsExecuting Then Err.Raise ERR_EXECUTING, "ExecuteWithTimeout", "عملية أخرى قيد التنفيذ" End If m_IsExecuting = True On Error GoTo Cleanup ExpandedPath = ExpandEnvVars(Command) ' فصل المسار التنفيذي عن المعاملات يدويًا If Left(ExpandedPath, 1) = """" Then Executable = Mid(ExpandedPath, 2, InStr(2, ExpandedPath, """") - 2) Arguments = Trim(Mid(ExpandedPath, InStr(2, ExpandedPath, """") + 2)) Else Dim Parts() As String Parts = Split(ExpandedPath, " ", 2) Executable = Parts(0) If UBound(Parts) > 0 Then Arguments = Parts(1) Else Arguments = "" End If For RetryIndex = 0 To RetryCount With ShellParams .Size = LenB(ShellParams) .Mask = SHELL_MASK_NOCLOSEPROCESS Or SHELL_MASK_DOENVSUBST Or SHELL_MASK_SUPPRESS_ERRORS .ShowCommand = WindowStyle .filePath = CanonicalizePath(Executable) ' المسار التنفيذي فقط .Arguments = Arguments ' المعاملات كما هي If RunAsAdmin Then .Verb = "runas" If ShellExecuteExW(VarPtr(ShellParams)) = 0 Then If RetryIndex = RetryCount Then Err.Raise ERR_EXECUTION_FAILED, "ExecuteWithTimeout", "فشل في تنفيذ الأمر بعد " & RetryCount + 1 & " محاولات: " & Command End If Else ProcessHandle = .ProcessHandle Exit For End If End With Next RetryIndex startTime = GetTickCount Do Result = MsgWaitForMultipleObjects(1, ProcessHandle, False, 100, QS_ALL_INPUT) DoEvents If GetExitCodeProcess(ProcessHandle, ExitCode) Then If ExitCode <> PROCESS_STILL_ACTIVE Then Exit Do End If If TimeoutMs > 0 Then If (GetTickCount - startTime) > TimeoutMs Then If TerminateProcess(ProcessHandle, PROCESS_TERMINATED) = 0 Then Debug.Print "فشل في إنهاء العملية بعد تجاوز المهلة" End If ExitCode = PROCESS_TERMINATED Exit Do End If End If If g_TerminateLoops Then Exit Do Loop ExecuteWithTimeout = ExitCode Cleanup: If ProcessHandle <> 0 Then CloseHandle ProcessHandle m_IsExecuting = False If Err.Number <> 0 Then Err.Raise Err.Number, "ExecuteWithTimeout", Err.Description End Function ' دالة لتشغيل أمر باستخدام WScript.Shell مع خيار الانتظار Public Function ExecuteWScript(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal, Optional ByVal WaitForCompletion As Boolean = False) As Long Dim WScriptShell As Object On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") ExecuteWScript = WScriptShell.Run(CommandLine, WindowStyle, WaitForCompletion) Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description Err.Raise Err.Number, "ExecuteWScript", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function ' دالة محسنة لتشغيل أمر باستخدام WScript.Shell والتقاط الناتج Public Function ExecuteWScriptCapture(ByVal CommandLine As String, Optional ByVal WindowStyle As ShellWindowStyle = WindowNormal) As String Dim WScriptShell As Object Dim ShellExec As Object Dim Output As String On Error GoTo ErrorHandler Set WScriptShell = CreateObject("WScript.Shell") Set ShellExec = WScriptShell.Exec(CommandLine) Do While ShellExec.Status = 0 DoEvents Loop Output = ShellExec.StdOut.ReadAll ExecuteWScriptCapture = Output Exit Function ErrorHandler: Debug.Print "خطأ في تشغيل الأمر عبر WScript: " & Err.Description ExecuteWScriptCapture = "" Err.Raise Err.Number, "ExecuteWScriptCapture", "خطأ في تشغيل الأمر عبر WScript: " & Err.Description End Function '======================================================================================================================= '------ الدوال المساعدة ' دالة لتوسيع متغيرات البيئة في سلسلة (مثل %windir%) Private Function ExpandEnvVars(ByVal Path As String) As String Dim Buffer As String Dim Length As Long If InStr(Path, "%") Then Length = ExpandEnvironmentStringsW(StrPtr(Path), 0, 0) If Length > 0 Then Buffer = String$(Length - 1, vbNullChar) If ExpandEnvironmentStringsW(StrPtr(Path), StrPtr(Buffer), Length) Then ExpandEnvVars = Left$(Buffer, Length - 1) Else Debug.Print "فشل توسيع متغيرات البيئة، يتم إرجاع المسار الأصلي: " & Path ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If Else ExpandEnvVars = Path End If End Function ' دالة لتبسيط المسار (مثل حل النقاط . و ..) Private Function CanonicalizePath(ByVal Path As String) As String Dim TempPath As String If InStr(Path, "\.") Or InStr(Path, ".\") Then If Len(Path) < MAX_PATH_LENGTH Then TempPath = String$(MAX_PATH_LENGTH - 1, vbNullChar) If PathCanonicalizeW(StrPtr(TempPath), StrPtr(Path)) Then CanonicalizePath = Left$(TempPath, InStr(TempPath, vbNullChar) - 1) Else Debug.Print "فشل تبسيط المسار، يتم إرجاع المسار الأصلي: " & Path CanonicalizePath = Path End If Else CanonicalizePath = Path End If Else CanonicalizePath = Path End If End Function ' دالة لاستخراج المعاملات من المسار Private Function ExtractArguments(ByRef Path As String) As String SysReAllocString VarPtr(ExtractArguments), PathGetArgsW(StrPtr(Path)) If LenB(ExtractArguments) Then PathRemoveArgsW StrPtr(Path) If InStr(ExtractArguments, """") Then ExtractArguments = Replace(ExtractArguments, """", """""") End If End Function ' دالة مساعدة لاستخراج اسم العملية من الأمر Private Function ExtractProcessName(ByVal CommandLine As String) As String Dim Parts() As String Dim FirstPart As String If Left(CommandLine, 1) = """" Then FirstPart = Mid(CommandLine, 2, InStr(2, CommandLine, """") - 2) Else Parts = Split(CommandLine, " ") FirstPart = Parts(0) End If ExtractProcessName = Mid(FirstPart, InStrRev(FirstPart, "\") + 1) End Function ' دالة لإنهاء عملية باستخدام WMI بناءً على اسم العملية Public Function KillProcess(sProcessName As String, Optional sHost As String = ".") As Boolean On Error GoTo Error_Handler Dim oWMI As Object Dim sWMIQuery As String Dim oCols As Object Dim oCol As Object Set oWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sHost & "\root\cimv2") sWMIQuery = "SELECT Name FROM Win32_Process" Set oCols = oWMI.ExecQuery(sWMIQuery) For Each oCol In oCols If LCase(sProcessName) = LCase(oCol.Name) Then oCol.Terminate End If Next oCol KillProcess = True Error_Handler_Exit: On Error Resume Next Set oCol = Nothing Set oCols = Nothing Set oWMI = Nothing Exit Function Error_Handler: Debug.Print "خطأ في KillProcess: " & Err.Description & " - رقم الخطأ: " & Err.Number KillProcess = False Resume Error_Handler_Exit End Function وأخيــــرا الامثلة : '======================================================================================================================= '------ أمثلة الاستدعاء ' مثال لاستدعاء ExecuteAndWait ' يفتح Notepad وينتظر إغلاقه Sub TestExecuteAndWait() Dim ExitCode As Long On Error Resume Next ExitCode = ExecuteAndWait("notepad.exe C:\test.txt", WindowNormal) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "رمز الخروج: " & ExitCode Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout ' يفتح الحاسبة وينتظر 5 ثوانٍ كحد أقصى Sub TestExecuteWithTimeout() Dim ProcessId As Long On Error Resume Next ProcessId = ExecuteWithTimeout("paint.exe", WindowMaximized, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript ' يشغل أمر dir في CMD وينتظر النتيجة Sub TestExecuteWScript() Dim Result As Long On Error Resume Next Result = ExecuteWScript("cmd.exe /c dir", WindowNormal, True) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScript مع إبقاء النافذة مفتوحة Sub TestExecuteWScript_KeepOpen() Dim Result As Long ' استخدام /k بدلاً من /c لإبقاء نافذة CMD مفتوحة بعد تنفيذ الأمر On Error Resume Next Result = ExecuteWScript("cmd.exe /k dir", WindowNormal, False) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "النتيجة: " & Result Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout لتشغيل CMD Sub TestExecuteWithTimeoutCMD() Dim ProcessId As Long ' تشغيل CMD مع أمر dir وانتظار 5 ثوانٍ كحد أقصى On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWithTimeout مع RunAsAdmin وإعادة المحاولة Sub TestExecuteWithTimeoutAdmin() Dim ProcessId As Long ' تشغيل CMD كمسؤول وانتظار 5 ثوانٍ كحد أقصى مع محاولتين On Error Resume Next ProcessId = ExecuteWithTimeout("cmd.exe /k dir", WindowNormal, 5000, True, 2) Err.Clear ' مسح أي أخطاء سابقة If Err.Number = PROCESS_TERMINATED Then MsgBox "اكتملت العملية برمز الخروج: " & ProcessId ElseIf Err.Number = 0 Then MsgBox "معرف العملية: " & ProcessId & " (انتهت المهلة)" Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub ' مثال لاستدعاء ExecuteWScriptCapture Sub TestExecuteWScriptCapture() Dim CommandOutput As String ' تنفيذ أمر dir والتقاط الناتج On Error Resume Next CommandOutput = ExecuteWScriptCapture("cmd.exe /c dir") Err.Clear ' مسح أي أخطاء سابقة If Err.Number = 0 Then MsgBox "ناتج الأمر:" & vbCrLf & CommandOutput Else MsgBox "حدث خطأ: " & Err.Description End If On Error GoTo 0 End Sub تمنياتى القلبيــــه بأكبر قدر ممكن من تحصيل المتعة والاستفاده

وايضا يمكنكم تجربة الكود فى هذا المرفق مع تغير المسار الرئيسي لمجلد حفظ الصور داخل الكود Public Function MainFolderpath() MainFolderpath = "\\192.168.85.70\hr-app\ScanFile\" End Function ScanerSettings.accdb

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

طيب ع العموم اتفضل دى التعديلات النهائيه بكل اللى طلبته تم تعديل واضافة الدوال اللازمة داخل الوحدة النمطية الكود النهائى والاخيـــــــــر Option Compare Database Option Explicit ' متغير عام لتخزين بيانات الحقول المستخدمة في آخر استعلام SQL Private StoredFieldsInfo As Variant ' التحقق مما إذا كانت السلسلة تحتوي على أرقام فقط Public Function IsNumericOnly(ByVal InputString As String, Optional AllowDecimal As Boolean = False, Optional AllowNegative As Boolean = False) As Boolean On Error Resume Next Dim CleanString As String CleanString = Trim(InputString) If CleanString = "" Or Not IsNumeric(CleanString) Then Exit Function If Not AllowDecimal And InStr(CleanString, ".") > 0 Then Exit Function If Not AllowNegative And Left(CleanString, 1) = "-" Then Exit Function If InStr(CleanString, " ") > 0 Then Exit Function IsNumericOnly = True End Function ' التحقق من صحة الإدخال الرقمي مع حد أقصى للطول Private Function ValidateNumericInput(InputValue As Variant, ByRef ErrorMessage As String, Optional MaxLength As Integer = 0, Optional AllowDecimal As Boolean = False) As String On Error Resume Next If IsEmpty(InputValue) Or IsNull(InputValue) Or Len(Trim(InputValue)) = 0 Then ValidateNumericInput = "" Exit Function End If Dim InputStr As String InputStr = CStr(InputValue) If Not IsNumericOnly(InputStr, AllowDecimal) Then ErrorMessage = "يرجى إدخال أرقام فقط" & IIf(AllowDecimal, " (يمكن أن تحتوي على فاصلة عشرية)!", "!") Exit Function End If If MaxLength > 0 And Len(InputStr) > MaxLength Then ErrorMessage = "الإدخال يتجاوز الحد الأقصى (" & MaxLength & " أرقام)!" Exit Function End If ValidateNumericInput = InputStr End Function ' توزيع الأرقام داخل مربعات النصوص Private Sub DistributeDigits(TextBoxCollection As Collection, NumericString As String) ' التحقق من أن الإدخال الرقمي ليس فارغًا If Trim(NumericString & "") = "" Then Dim i As Integer For i = 1 To TextBoxCollection.Count TextBoxCollection(i).Value = "" Next i Exit Sub End If For i = 1 To TextBoxCollection.Count If i <= Len(NumericString) Then TextBoxCollection(i).Value = Mid(NumericString, i, 1) Else TextBoxCollection(i).Value = "" End If Next i End Sub ' توزيع الأرقام العشرية (الجزء الصحيح والعشري) Private Sub DistributeDecimal(TextBoxCollection As Collection, NumericString As String) On Error Resume Next ' التحقق من أن الإدخال الرقمي ليس فارغًا If Trim(NumericString & "") = "" Then Dim i As Integer For i = 1 To TextBoxCollection.Count TextBoxCollection(i).Value = "" Next i Exit Sub End If Dim parts() As String parts = Split(NumericString, ".") If TextBoxCollection.Count >= 1 Then TextBoxCollection(1).Value = Nz(parts(0), "") ' الجزء الصحيح If TextBoxCollection.Count >= 2 Then TextBoxCollection(2).Value = Nz(parts(1), "00") ' الجزء العشري (افتراضي 00) End Sub ' جمع مربعات النصوص Private Function CollectTextBoxes(TargetObject As Object, ControlPrefix As String, MaxFields As Integer) As Collection Dim i As Integer, ctrl As Control Set CollectTextBoxes = New Collection For i = 1 To MaxFields On Error Resume Next Set ctrl = TargetObject.Controls(ControlPrefix & i) If Not ctrl Is Nothing Then CollectTextBoxes.Add ctrl On Error GoTo 0 Next i End Function ' توزيع الإدخال الرقمي على مربعات النصوص مع خيار فصل الأرقام العشرية Public Sub DistributeNumericInput(Optional TargetObject As Object = Nothing, Optional InputValue As Variant, _ Optional ControlPrefix As String = "", Optional MaxFields As Integer = 0, _ Optional SplitDecimal As Boolean = False) On Error GoTo ErrorHandler ' التحقق من القيم الفارغة If IsEmpty(InputValue) Or IsNull(InputValue) Or Trim(InputValue & "") = "" Then ' إعادة تهيئة مربعات النصوص إلى فارغة Dim TextBoxes As Collection Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, MaxFields) Dim i As Integer For i = 1 To TextBoxes.Count TextBoxes(i).Value = "" Next i Exit Sub End If Dim ValidInput As String, ErrorMessage As String ValidInput = ValidateNumericInput(InputValue, ErrorMessage, MaxFields, SplitDecimal) If ValidInput = "" Then If ErrorMessage <> "" Then MsgBox ErrorMessage, vbExclamation, "خطأ في الإدخال" Exit Sub End If If MaxFields = 0 Then MaxFields = IIf(SplitDecimal, 2, Len(ValidInput)) If TargetObject Is Nothing Then Debug.Print "الإدخال الموزع: " & ValidInput Exit Sub End If Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, MaxFields) If SplitDecimal Then If TextBoxes.Count < 2 Then MsgBox "عدد مربعات النصوص (" & TextBoxes.Count & ") أقل من المطلوب (2) للأرقام العشرية!", vbExclamation, "خطأ" Exit Sub End If DistributeDecimal TextBoxes, ValidInput Else If TextBoxes.Count < Len(ValidInput) Then MsgBox "عدد مربعات النصوص (" & TextBoxes.Count & ") أقل من طول الإدخال (" & Len(ValidInput) & ")!", vbExclamation, "خطأ" Exit Sub End If DistributeDigits TextBoxes, ValidInput End If Exit Sub ErrorHandler: MsgBox "خطأ في توزيع الإدخال: " & Err.Description, vbCritical, "خطأ" End Sub ' التحقق من صحة الرقم القومي Private Function ValidateNationalID(NationalID As Variant, ByRef ErrorMessage As String) As String On Error Resume Next Dim InputStr As String InputStr = Trim(Nz(NationalID, "")) If InputStr = "" Or Not IsNumericOnly(InputStr) Or Len(InputStr) <> 14 Then ErrorMessage = "يجب إدخال رقم قومي صحيح مكون من 14 رقمًا!" Exit Function End If ValidateNationalID = InputStr End Function ' استخراج تاريخ الميلاد من الرقم القومي بصيغة YYYY-MM-DD Public Function ExtractBirthDateFromID(NationalID As Variant) As String On Error GoTo ErrorHandler Dim ValidInput As String, YearPart As String, MonthPart As String, DayPart As String, CenturyCode As String, ErrorMessage As String ValidInput = ValidateNationalID(NationalID, ErrorMessage) If ValidInput = "" Then ExtractBirthDateFromID = "خطأ: " & ErrorMessage Exit Function End If CenturyCode = Mid(ValidInput, 1, 1) YearPart = Mid(ValidInput, 2, 2) MonthPart = Mid(ValidInput, 4, 2) DayPart = Mid(ValidInput, 6, 2) Select Case CenturyCode Case "2": YearPart = "19" & YearPart Case "3": YearPart = "20" & YearPart Case "4": YearPart = "21" & YearPart Case Else: ExtractBirthDateFromID = "خطأ: رمز القرن غير صالح!" Exit Function End Select If Not IsDate(YearPart & "/" & MonthPart & "/" & DayPart) Then ExtractBirthDateFromID = "خطأ: تاريخ ميلاد غير صالح!" Exit Function End If If CDate(YearPart & "-" & MonthPart & "-" & DayPart) > Date Then ExtractBirthDateFromID = "خطأ: تاريخ الميلاد في المستقبل!" Exit Function End If ExtractBirthDateFromID = YearPart & "-" & MonthPart & "-" & DayPart Exit Function ErrorHandler: ExtractBirthDateFromID = "خطأ: " & Err.Description End Function ' توزيع تاريخ الميلاد في 3 مربعات نص (السنة - الشهر - اليوم) Public Sub DistributeBirthDateFromID(Optional TargetObject As Object = Nothing, Optional NationalID As Variant, Optional ControlPrefix As String = "") On Error GoTo ErrorHandler Dim BirthDate As String, TextBoxes As Collection BirthDate = ExtractBirthDateFromID(NationalID) If Left(BirthDate, 5) = "خطأ" Then MsgBox BirthDate, vbExclamation, "خطأ في الرقم القومي" Exit Sub End If If TargetObject Is Nothing Then Debug.Print "السنة: " & Left(BirthDate, 4) Debug.Print "الشهر: " & Mid(BirthDate, 6, 2) Debug.Print "اليوم: " & Right(BirthDate, 2) Exit Sub End If Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, 3) If TextBoxes.Count < 3 Then MsgBox "عدد مربعات النص غير كافٍ! (مطلوب 3)", vbExclamation, "خطأ" Exit Sub End If TextBoxes(1).Value = Left(BirthDate, 4) TextBoxes(2).Value = Mid(BirthDate, 6, 2) TextBoxes(3).Value = Right(BirthDate, 2) Exit Sub ErrorHandler: MsgBox "خطأ في توزيع تاريخ الميلاد: " & Err.Description, vbCritical, "خطأ" End Sub ' دالة اختبار لطباعة تاريخ الميلاد Public Sub TestPrintDistributeBirthDate(NationalID As Variant) Dim BirthDate As String BirthDate = ExtractBirthDateFromID(NationalID) If Left(BirthDate, 5) = "خطأ" Then Debug.Print BirthDate Else Debug.Print "تجربة الطباعة للرقم القومي: " & NationalID Debug.Print "تاريخ الميلاد: " & BirthDate End If End Sub ' إنشاء استعلام SQL ديناميكي Public Function GenerateDynamicSQL(tableName As String, ParamArray RequiredFieldsDistribute() As Variant) As String On Error GoTo ErrorHandler Dim sqlQuery As String, i As Integer, j As Integer, fieldName As String, MaxDigits As Integer, fieldPrefix As String If Trim(tableName) = "" Or UBound(RequiredFieldsDistribute) < 0 Then GenerateDynamicSQL = "خطأ: الجدول أو الحقول غير محددة" Exit Function End If StoredFieldsInfo = RequiredFieldsDistribute sqlQuery = "SELECT " & tableName & ".*, " For i = LBound(RequiredFieldsDistribute) To UBound(RequiredFieldsDistribute) fieldName = RequiredFieldsDistribute(i)(0) MaxDigits = RequiredFieldsDistribute(i)(1) fieldPrefix = RequiredFieldsDistribute(i)(2) For j = 1 To MaxDigits sqlQuery = sqlQuery & "IIf(IsNull([" & fieldName & "]) OR Len([" & fieldName & "]) < " & j & ", Null, Mid([" & fieldName & "], " & j & ", 1)) AS " & fieldPrefix & j & ", " Next j Next i sqlQuery = Left(sqlQuery, Len(sqlQuery) - 2) & " FROM " & tableName & ";" GenerateDynamicSQL = sqlQuery Exit Function ErrorHandler: GenerateDynamicSQL = "خطأ: " & Err.Description End Function ' حذف مصادر البيانات من الحقول غير المستخدمة Public Sub ClearUnusedTextBoxes(frm As Form) On Error GoTo ErrorHandler Dim ctl As Control, i As Integer, Prefix As String, MaxDigits As Integer If IsEmpty(StoredFieldsInfo) Or Not IsArray(StoredFieldsInfo) Then Exit Sub For i = LBound(StoredFieldsInfo) To UBound(StoredFieldsInfo) Prefix = StoredFieldsInfo(i)(2) MaxDigits = StoredFieldsInfo(i)(1) For Each ctl In frm.Controls If TypeName(ctl) = "TextBox" And ctl.Name Like Prefix & "*" Then Dim num As Integer num = Val(Mid(ctl.Name, Len(Prefix) + 1)) If num > MaxDigits Then ctl.ControlSource = "" End If Next ctl Next i Exit Sub ErrorHandler: Debug.Print "خطأ في ClearUnusedTextBoxes: " & Err.Description End Sub ' استخراج أجزاء التاريخ (سنة، شهر، يوم) من تاريخ مدخل Public Function ExtractDateParts(ByVal InputDate As Variant, ByRef ErrorMessage As String) As Variant On Error GoTo ErrorHandler Dim DateParts(1 To 3) As String Dim TempDate As Date ' تهيئة المصفوفة بقيم افتراضية فارغة DateParts(1) = "" DateParts(2) = "" DateParts(3) = "" ' حالة الحقل الفارغ If IsEmpty(InputDate) Or IsNull(InputDate) Or Trim(InputDate & "") = "" Then ExtractDateParts = DateParts ' إرجاع أجزاء فارغة Exit Function End If ' حالة الإدخال غير الصحيح If Not IsDate(InputDate) Then ErrorMessage = "تنسيق التاريخ غير صحيح!" Exit Function End If ' تحويل إلى تاريخ TempDate = CDate(InputDate) ' (اختياري) التحقق من أن التاريخ ليس في المستقبل ' If TempDate > Date Then ' ErrorMessage = "التاريخ لا يمكن أن يكون في المستقبل!" ' Exit Function ' End If ' تعبئة الأجزاء بتنسيق صحيح DateParts(1) = Format(Year(TempDate), "0000") DateParts(2) = Format(Month(TempDate), "00") DateParts(3) = Format(Day(TempDate), "00") ExtractDateParts = DateParts Exit Function ErrorHandler: ErrorMessage = "خطأ غير متوقع: " & Err.Description ExtractDateParts = Array("", "", "") ' إرجاع قيم فارغة مع رسالة خطأ End Function ' توزيع أجزاء التاريخ على مربعات النصوص Public Sub DistributeDateParts(Optional TargetObject As Object = Nothing, Optional InputDate As Variant, _ Optional ControlPrefix As String = "DatePart") On Error GoTo ErrorHandler Dim DateParts As Variant, TextBoxes As Collection Dim ErrorMessage As String DateParts = ExtractDateParts(InputDate, ErrorMessage) If Not IsArray(DateParts) Then MsgBox ErrorMessage, vbExclamation, "خطأ في التاريخ" Exit Sub End If If TargetObject Is Nothing Then Debug.Print "السنة: " & DateParts(1) Debug.Print "الشهر: " & DateParts(2) Debug.Print "اليوم: " & DateParts(3) Exit Sub End If Set TextBoxes = CollectTextBoxes(TargetObject, ControlPrefix, 3) If TextBoxes.Count < 3 Then MsgBox "يجب توفير 3 مربعات نصية للتوزيع!", vbExclamation, "خطأ" Exit Sub End If TextBoxes(1).Value = DateParts(1) ' السنة TextBoxes(2).Value = DateParts(2) ' الشهر TextBoxes(3).Value = DateParts(3) ' اليوم Exit Sub ErrorHandler: MsgBox "خطأ في التوزيع: " & Err.Description, vbCritical, "خطأ" End Sub ' دالة اختبار باستخدام DateSerial Public Sub TestPrintDistributeDate() Dim InputDate As Date Dim parts As Variant Dim ErrorMessage As String ' إنشاء التاريخ باستخدام DateSerial لتجنب الغموض InputDate = DateSerial(2025, 5, 9) ' 9 May 2025 (السنة، الشهر، اليوم) parts = ExtractDateParts(InputDate, ErrorMessage) If IsArray(parts) Then Debug.Print "السنة: " & parts(1) ' 2025 Debug.Print "الشهر: " & parts(2) ' 05 Debug.Print "اليوم: " & parts(3) ' 09 Else Debug.Print "خطأ: " & ErrorMessage End If End Sub فصل وتوزيع ارقام الرقم القومى 3.accdb

اعانكم الله تعالى طيب و بما انك برضو منتظر هذا الموضوع به تعديلات قد تسعدكم وتفتح افاقا جديده لافكاركم

السلام عليكم ورحمة الله تعالى وبركاته اليكم هديه اخرى ولكن الحق أحق أن يتبع كل الشكر و التقدير لاستاذى الجليل ومعلمى القدير و اخى الحبيب الاستاذ @Foksh على موضوع : ⭐ هدية ~ تغيير لغة النظام في Unicode⭐ قمت بعمل تحديثات جذرية فى هيكل وبناء الكود المميزات : عدم الاعتماد على وسيط بانشاء ملف فى مسار محدد لتمرير اومر الاعدادات ثم حذفه بعد تمرريرها وتطبيقها اضافة نموذج جديد للتحكم فى اختيار وتنسيق الوقت والتاريخ بشكل فورى امكانيه اضافة تخطيط لوحات مفاتيح للغات مختلفة حسب الحاجة والرغبه امكانية حذف تخطيط لغة/لغات لوحات مفاتيح من مربع القيم باختيار مفرد او متعدد لاكثر من لغة التخلص من تخطيطات لوحات المفاتيح المزعجة وحذفها بسهوله و التى قد تصادف العديد عند استخدام قواعد بيانات تعديل التنسيق للوقت والتاريخ او اضافة تخطيط لغة مفاتيح او حذفها لا يتطلب اعادة التشغيل مطلقا امكانية نقل النماذج لاى قاعدة للعمل فورا بدون اى تعديلات تذكر واخيـــــــــــــر المرفق اتمنى لكم تجربة ممتعة LanguageCheck V3.0.1.accdb

استاذى الجليل و معلمى القدير و والدى الحبيب بالعكس انا للمرة الاولى فى حياتى اختلف مع حضرتك انتم وكل اساتذتنا العظماء كالنجوم اللامعه يقتضى ويهتدى بهم كل طلاب العلم فى غياهب الظلمات بارك الله فيكم وفى اعماركم واعمالكم وشكر الله لكم واحسن اليكم

ههههههههه طبها لازم اخاف بس انا برضو قلت انك مصباح بتضوى ضلمات حياتنا بنورك يا عسل ما لنا غنى عنك جميل لكن برضو النجوم حاجه تانيه و فى حته تانيه خااااااااااااااااااااالص