ابو جودي

مشاركة مع اساتذتى الكرام واحبابى اليك هذه الاكواد Public Function CalculateTimeDifference(startDate As Variant, endDate As Variant) As String On Error GoTo ErrorHandler Dim totalSeconds As Double Dim days As Long Dim hours As Long Dim minutes As Long Dim seconds As Long ' التحقق من أن التاريخين ليسا فارغين وهما صالحان If IsNull(startDate) Or IsNull(endDate) Then CalculateTimeDifference = "أحد التواريخ فارغ" Exit Function ElseIf Not IsDate(startDate) Or Not IsDate(endDate) Then CalculateTimeDifference = "أحد التواريخ غير صالح" Exit Function End If ' تحويل التاريخين إلى نوع Date Dim start As Date Dim endD As Date start = CDate(startDate) endD = CDate(endDate) ' حساب الفرق بالثواني totalSeconds = DateDiff("s", start, endD) ' التحقق من القيمة السالبة If totalSeconds < 0 Then CalculateTimeDifference = "تاريخ النهاية يجب أن يكون بعد تاريخ البداية" Exit Function End If ' تحويل الثواني إلى أيام days = Int(totalSeconds / 86400) ' 86400 = عدد ثواني اليوم totalSeconds = totalSeconds - (days * 86400) ' تحويل الثواني إلى ساعات hours = Int(totalSeconds / 3600) ' 3600 = عدد ثواني الساعة totalSeconds = totalSeconds - (hours * 3600) ' تحويل الثواني إلى دقائق minutes = Int(totalSeconds / 60) ' الثواني المتبقية seconds = totalSeconds - (minutes * 60) ' إرجاع النتيجة كنص CalculateTimeDifference = days & " أيام, " & hours & " ساعات, " & minutes & " دقائق, " & seconds & " ثواني" Exit Function ErrorHandler: CalculateTimeDifference = "حدث خطأ: " & Err.Description End Function Public Function CalculateTimeParts(startDate As Variant, endDate As Variant, part As String) As Long On Error GoTo ErrorHandler Dim years As Long Dim months As Long Dim days As Long Dim hours As Long Dim minutes As Long Dim seconds As Long Dim tempDate As Date ' التحقق من أن التاريخين ليسا فارغين If IsNull(startDate) Or IsNull(endDate) Then CalculateTimeParts = 0 Exit Function End If ' التحقق من ترتيب التواريخ If startDate > endDate Then CalculateTimeParts = 0 Exit Function End If ' البدء بحساب الفرقات الزمنية tempDate = startDate ' حساب الفرق في السنوات years = DateDiff("yyyy", tempDate, endDate) tempDate = DateAdd("yyyy", years, tempDate) ' حساب الفرق في الأشهر months = DateDiff("m", tempDate, endDate) tempDate = DateAdd("m", months, tempDate) ' التأكد من عدم وجود قيم سالبة بعد التعديلات If tempDate > endDate Then months = months - 1 tempDate = DateAdd("m", -1, tempDate) End If ' حساب الفرق في الأيام days = DateDiff("d", tempDate, endDate) tempDate = DateAdd("d", days, tempDate) ' حساب الفرق في الساعات hours = DateDiff("h", tempDate, endDate) tempDate = DateAdd("h", hours, tempDate) ' حساب الفرق في الدقائق minutes = DateDiff("n", tempDate, endDate) tempDate = DateAdd("n", minutes, tempDate) ' حساب الفرق في الثواني seconds = DateDiff("s", tempDate, endDate) ' التأكد من عدم وجود قيم سالبة نهائياً If months < 0 Then months = 0 If days < 0 Then days = 0 If hours < 0 Then hours = 0 If minutes < 0 Then minutes = 0 If seconds < 0 Then seconds = 0 ' إرجاع الجزء المطلوب Select Case part Case "Years": CalculateTimeParts = years Case "Months": CalculateTimeParts = months Case "Days": CalculateTimeParts = days Case "Hours": CalculateTimeParts = hours Case "Minutes": CalculateTimeParts = minutes Case "Seconds": CalculateTimeParts = seconds Case Else: CalculateTimeParts = 0 End Select Exit Function ErrorHandler: CalculateTimeParts = 0 End Function الاستعلام الاول والمعتمد على الإجراء : CalculateTimeDifference SELECT Tbl_IN_OUT.ID, Tbl_IN_OUT.Nname, Tbl_IN_OUT.Start_Day, Tbl_IN_OUT.End_Day, CalculateTimeDifference([Start_Day], [End_Day]) AS Sub_Time FROM Tbl_IN_OUT; الاستعلام الثانى والمعتمد على الإجراء : CalculateTimeParts SELECT Tbl_IN_OUT.ID, Tbl_IN_OUT.Nname, Tbl_IN_OUT.Start_Day, Tbl_IN_OUT.End_Day, CalculateTimeParts([Start_Day], [End_Day], "Years") AS Years_Diff, CalculateTimeParts([Start_Day], [End_Day], "Months") AS Months_Diff, CalculateTimeParts([Start_Day], [End_Day], "Days") AS Days_Diff, CalculateTimeParts([Start_Day], [End_Day], "Hours") AS Hours_Diff, CalculateTimeParts([Start_Day], [End_Day], "Minutes") AS Minutes_Diff, CalculateTimeParts([Start_Day], [End_Day], "Seconds") AS Seconds_Diff FROM Tbl_IN_OUT;

الكلام مش مفهوم وبصراحة قواعد البيانات اللى بتكوووووون زحمه زياده عن الللازم ما باحاول حتى افتحها لانها هتعمل لى صداع وانا معنديش استعداد ولا وقت للتحليل وسط هذا الزحام الشديد وانا نوهت ووضحت هذه النقطه من قبل

انت صح وانا بس خليت الكود اكثر مرونه ليعمل مع كل انواع الحقول نص او رقم او تاريخ

استبدل كود الموديول بالكود التالى Public Function Horizontal(tabelle As String, Feld1 As String, Feld2 As String, valFeld1 As Variant) As String Dim DB As DAO.Database Dim rs As DAO.Recordset Dim fieldType As Integer Dim sqlWhere As String Dim first As Boolean ' تعيين قاعدة البيانات الحالية Set DB = CurrentDb ' استرجاع نوع الحقل Feld1 fieldType = DB.TableDefs(tabelle).Fields(Feld1).Type ' تنسيق القيمة بناءً على نوع الحقل Select Case fieldType Case dbText, dbMemo, dbChar ' النصوص: وضع القيمة بين علامات اقتباس مفردة مع معالجة علامات الاقتباس الداخلية sqlWhere = "[" & Feld1 & "]='" & Replace(valFeld1, "'", "''") & "'" Case dbDate, dbTime, dbTimeStamp ' التواريخ: وضع القيمة بين علامات # مع تنسيق التاريخ sqlWhere = "[" & Feld1 & "]=#" & Format(valFeld1, "yyyy-mm-dd hh:nn:ss") & "#" Case dbInteger, dbLong, dbSingle, dbDouble, dbCurrency, dbDecimal ' الأرقام: إدراج القيمة مباشرة sqlWhere = "[" & Feld1 & "]=" & valFeld1 Case Else ' معالجة الأنواع غير المدعومة MsgBox "نوع البيانات غير مدعوم للحقل: " & Feld1, vbExclamation Exit Function End Select ' إنشاء وتنفيذ استعلام SQL Set rs = DB.OpenRecordset("SELECT DISTINCT [" & Feld2 & "] FROM [" & tabelle & "] WHERE " & sqlWhere & " ORDER BY [" & Feld2 & "] DESC") ' تهيئة متغير للسجل الأول first = True ' معالجة السجلات المسترجعة Do While Not rs.EOF If first Then Horizontal = rs(Feld2) ' القيمة الأولى first = False Else Horizontal = Horizontal & vbCrLf & rs(Feld2) ' إضافة القيم التالية مع فاصل سطر End If rs.MoveNext Loop ' تحرير الموارد rs.Close Set rs = Nothing Set DB = Nothing End Function

شوف يا فؤش خطر بالى كتابة الكود بالشكل التالى فى وحده نمطية عامة ' تعداد لتحديد نوع العنصر Public Enum fileType ftAccessDB = 1 ' قاعدة بيانات Access ftExcel = 2 ' ملف Excel ftWord = 3 ' ملف Word ftText = 4 ' ملف نصي ftFolder = 5 ' مجلد ftDrive = 6 ' قسم (Drive) ftAnyFile = 7 ' أي ملف End Enum ' تعداد لتحديد نوع المعلومات المطلوبة Public Enum infoType itPathOnly = 1 ' جلب المسار فقط itSizeOnly = 2 ' جلب الحجم فقط itPathAndSize = 3 ' جلب المسار والحجم itFileNameOnly = 4 ' جلب اسم الملف فقط itFileExtension = 5 ' جلب امتداد الملف فقط itFileNameAndExt = 6 ' جلب اسم الملف مع الامتداد itCreationDate = 7 ' جلب تاريخ الإنشاء itModifiedDate = 8 ' جلب تاريخ التعديل itFileCount = 9 ' جلب عدد الملفات (لمجلد) itFreeSpace = 10 ' جلب المساحة الحرة (لقسم) itTotalSpace = 11 ' جلب المساحة الإجمالية (لقسم) itDriveType = 12 ' جلب نوع القسم itParentPath = 13 ' جلب المسار الأصلي End Enum ' تعداد لتحديد الامتدادات Public Enum FileExtension feAccessDB = 1 ' *.accdb;*.mdb feExcel = 2 ' *.xlsx;*.xls feWord = 3 ' *.docx;*.doc feText = 4 ' *.txt feAnyFile = 7 ' *.* End Enum ' دالة مساعدة للحصول على وصف وامتداد بناءً على FileType Private Function GetFileFilter(fileType As fileType) As Variant Dim description As String Dim extension As String Select Case fileType Case ftAccessDB description = "قواعد بيانات Access" extension = "*.accdb;*.mdb" Case ftExcel description = "ملفات Excel" extension = "*.xlsx;*.xls" Case ftWord description = "ملفات Word" extension = "*.docx;*.doc" Case ftText description = "ملفات نصية" extension = "*.txt" Case ftAnyFile description = "كل الملفات" extension = "*.*" Case Else description = vbNullString extension = vbNullString End Select GetFileFilter = Array(description, extension) End Function ' دالة رئيسية للحصول على معلومات العنصر Public Function GetFileInfo(Optional inputPath As String = vbNullString, _ Optional txtPath As TextBox = Nothing, _ Optional txtSize As TextBox = Nothing, _ Optional txtName As TextBox = Nothing, _ Optional txtExt As TextBox = Nothing, _ Optional txtExtra As TextBox = Nothing, _ Optional fileType As fileType = ftAccessDB, _ Optional infoType As infoType = itPathAndSize, _ Optional decimalPlaces As Integer = 2) As String On Error GoTo ErrorHandler Dim fso As Object Dim shellApp As Object Dim dbPath As String Dim totalSize As Double Dim fileName As String Dim fileExt As String Dim formatStr As String ' إعداد تنسيق الحجم formatStr = "0." & String(decimalPlaces, "0") ' إنشاء كائن FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") ' التحقق من المسار المدخل مباشرة فقط If Len(Trim(inputPath)) > 0 Then dbPath = inputPath Else ' إذا لم يتم تمرير inputPath، افتح المستعرض دائمًا Set shellApp = CreateObject("Shell.Application") Select Case fileType Case ftFolder Dim folder As Object Set folder = shellApp.BrowseForFolder(0, "اختر مجلدًا", 0) If Not folder Is Nothing Then dbPath = folder.Self.path Else GetFileInfo = "لم يتم اختيار مجلد" Exit Function End If Case ftDrive Dim driveFolder As Object Set driveFolder = shellApp.BrowseForFolder(0, "اختر قسمًا", 0, 17) ' 17 = ssfDRIVES If Not driveFolder Is Nothing Then dbPath = driveFolder.Self.path If Right(dbPath, 1) <> "\" Then dbPath = dbPath & "\" Else GetFileInfo = "لم يتم اختيار قسم" Exit Function End If Case Else ' ملفات Dim fd As Object Set fd = Application.fileDialog(3) ' 3 = msoFileDialogFilePicker With fd .Title = "اختر ملفًا" .Filters.Clear Dim filter As Variant filter = GetFileFilter(fileType) If Len(filter(0)) > 0 Then .Filters.Add filter(0), filter(1) End If .AllowMultiSelect = False If .Show = -1 Then dbPath = .SelectedItems(1) Else GetFileInfo = "لم يتم اختيار ملف" Exit Function End If End With End Select End If ' التحقق من وجود العنصر If Not fso.FileExists(dbPath) And Not fso.FolderExists(dbPath) And Not fso.DriveExists(dbPath) Then GetFileInfo = "العنصر غير موجود" Exit Function End If ' استخراج المعلومات بناءً على infoType Select Case infoType Case itPathOnly If Not txtPath Is Nothing Then txtPath.Value = dbPath GetFileInfo = dbPath Case itSizeOnly totalSize = GetSize(fso, dbPath, fileType) Dim sizeStr As String sizeStr = FormatSize(totalSize, formatStr) If Not txtSize Is Nothing Then txtSize.Value = sizeStr GetFileInfo = sizeStr Case itPathAndSize totalSize = GetSize(fso, dbPath, fileType) sizeStr = FormatSize(totalSize, formatStr) If Not txtPath Is Nothing Then txtPath.Value = dbPath If Not txtSize Is Nothing Then txtSize.Value = sizeStr GetFileInfo = dbPath & " - " & sizeStr Case itFileNameOnly If fso.FileExists(dbPath) Then fileName = fso.GetBaseName(dbPath) If Not txtName Is Nothing Then txtName.Value = fileName GetFileInfo = fileName Else GetFileInfo = "المسار ليس ملفًا" End If Case itFileExtension If fso.FileExists(dbPath) Then fileExt = fso.GetExtensionName(dbPath) If Not txtExt Is Nothing Then txtExt.Value = fileExt GetFileInfo = fileExt Else GetFileInfo = "المسار ليس ملفًا" End If Case itFileNameAndExt If fso.FileExists(dbPath) Then fileName = fso.GetFileName(dbPath) If Not txtName Is Nothing Then txtName.Value = fileName GetFileInfo = fileName Else GetFileInfo = "المسار ليس ملفًا" End If Case itCreationDate If fso.FileExists(dbPath) Then GetFileInfo = fso.GetFile(dbPath).DateCreated ElseIf fso.FolderExists(dbPath) Then GetFileInfo = fso.GetFolder(dbPath).DateCreated ElseIf fso.DriveExists(dbPath) Then GetFileInfo = "غير متاح للأقسام" End If If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo Case itModifiedDate If fso.FileExists(dbPath) Then GetFileInfo = fso.GetFile(dbPath).DateLastModified ElseIf fso.FolderExists(dbPath) Then GetFileInfo = fso.GetFolder(dbPath).DateLastModified ElseIf fso.DriveExists(dbPath) Then GetFileInfo = "غير متاح للأقسام" End If If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo Case itFileCount If fso.FolderExists(dbPath) Then GetFileInfo = CStr(fso.GetFolder(dbPath).files.Count) If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo Else GetFileInfo = "المسار ليس مجلدًا" End If Case itFreeSpace If fso.DriveExists(dbPath) Then totalSize = fso.GetDrive(fso.GetDriveName(dbPath)).FreeSpace sizeStr = FormatSize(totalSize, formatStr) If Not txtSize Is Nothing Then txtSize.Value = sizeStr GetFileInfo = sizeStr Else GetFileInfo = "المسار ليس قسمًا" End If Case itTotalSpace If fso.DriveExists(dbPath) Then totalSize = fso.GetDrive(fso.GetDriveName(dbPath)).totalSize sizeStr = FormatSize(totalSize, formatStr) If Not txtSize Is Nothing Then txtSize.Value = sizeStr GetFileInfo = sizeStr Else GetFileInfo = "المسار ليس قسمًا" End If Case itDriveType If fso.DriveExists(dbPath) Then Select Case fso.GetDrive(fso.GetDriveName(dbPath)).FileSystem Case "FAT", "FAT32", "NTFS", "exFAT" GetFileInfo = fso.GetDrive(fso.GetDriveName(dbPath)).FileSystem Case Else GetFileInfo = "غير معروف" End Select If Not txtExtra Is Nothing Then txtExtra.Value = GetFileInfo Else GetFileInfo = "المسار ليس قسمًا" End If Case itParentPath If fso.FileExists(dbPath) Then GetFileInfo = fso.GetParentFolderName(dbPath) ElseIf fso.FolderExists(dbPath) Then GetFileInfo = fso.GetParentFolderName(dbPath) ElseIf fso.DriveExists(dbPath) Then GetFileInfo = "لا يوجد مسار أصلي للقسم" End If If Not txtPath Is Nothing Then txtPath.Value = GetFileInfo End Select Exit Function ErrorHandler: GetFileInfo = "حدث خطأ (" & Err.Number & "): " & Err.description If Not fso Is Nothing Then Set fso = Nothing If Not shellApp Is Nothing Then Set shellApp = Nothing End Function ' دالة مساعدة لحساب الحجم Private Function GetSize(fso As Object, path As String, fileType As fileType) As Double Select Case fileType Case ftAccessDB, ftExcel, ftWord, ftText, ftAnyFile If fso.FileExists(path) Then GetSize = fso.GetFile(path).size End If Case ftFolder If fso.FolderExists(path) Then GetSize = GetFolderSize(fso.GetFolder(path)) End If Case ftDrive If fso.DriveExists(path) Then With fso.GetDrive(fso.GetDriveName(path)) GetSize = .totalSize - .FreeSpace End With End If End Select End Function ' دالة مساعدة لتنسيق الحجم Private Function FormatSize(size As Double, formatStr As String) As String If size < 1024 Then FormatSize = Format(size, formatStr) & " بايت" ElseIf size < 1024 ^ 2 Then FormatSize = Format(size / 1024, formatStr) & " كيلوبايت" ElseIf size < 1024 ^ 3 Then FormatSize = Format(size / (1024 ^ 2), formatStr) & " ميجابايت" Else FormatSize = Format(size / (1024 ^ 3), formatStr) & " جيجابايت" End If End Function ' دالة مساعدة لحساب حجم المجلد Private Function GetFolderSize(fld As Object) As Double On Error Resume Next Dim subFld As Object Dim file As Object Dim totalSize As Double For Each file In fld.files totalSize = totalSize + file.size Next file For Each subFld In fld.SubFolders totalSize = totalSize + GetFolderSize(subFld) Next subFld GetFolderSize = totalSize End Function

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

الحمد لله تعالى اشكرك جدا يا صديقى العزيز وسعيد جدا جدا بمرورك واهتمامك

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

رائع جدا جدا الحل السابق فى ابسط صوره الحل التالى اكثر تقدما المميزات تعداد للالوان يمكن اضافة الالوان التى تريدها مستقبلا تعداد للخصائص يمكن اضافة الخصائص التى تريدها " خلفية مربع النص , او لون الخط المستخدم " كود الوحده النمطيه Option Compare Database Option Explicit Public Enum FlashColors FlashWhite = 16777215 ' الأبيض - White (vbWhite) FlashBlack = 0 ' الأسود - Black (vbBlack) FlashRed = 255 ' الأحمر - Red (vbRed) FlashGreen = 65280 ' الأخضر - Green (vbGreen) FlashBlue = 16711680 ' الأزرق - Blue (vbBlue) FlashYellow = 65535 ' الأصفر - Yellow (vbYellow) FlashMagenta = 16711935 ' الماجنتا - Magenta (vbMagenta) FlashCyan = 16776960 ' السماوي - Cyan (vbCyan) FlashOrange = 42495 ' البرتقالي - Orange (RGB: 255, 165, 0) FlashPurple = 8388736 ' البنفسجي - Purple (RGB: 128, 0, 128) FlashPink = 13353215 ' الوردي - Pink (RGB: 255, 192, 203) FlashLime = 65280 ' الليموني - Lime (RGB: 0, 255, 0) FlashTeal = 32896 ' البترولي - Teal (RGB: 0, 128, 128) FlashViolet = 15631086 ' الفيوليت - Violet (RGB: 238, 130, 238) FlashBrown = 2763429 ' البني - Brown (RGB: 165, 42, 42) FlashGold = 55295 ' الذهبي - Gold (RGB: 255, 215, 0) FlashSilver = 12632256 ' الفضي - Silver (RGB: 192, 192, 192) FlashGray = 8421504 ' الرمادي - Gray (RGB: 128, 128, 128) FlashDarkRed = 139 ' الأحمر الداكن - Dark Red (RGB: 139, 0, 0) FlashDarkGreen = 25600 ' الأخضر الداكن - Dark Green (RGB: 0, 100, 0) FlashDarkBlue = 9109504 ' الأزرق الداكن - Dark Blue (RGB: 0, 0, 139) FlashOlive = 32896 ' الزيتوني - Olive (RGB: 128, 128, 0) FlashMaroon = 128 ' المارون - Maroon (RGB: 128, 0, 0) FlashNavy = 8388608 ' الكحلي - Navy (RGB: 0, 0, 128) FlashTurquoise = 13757312 ' التركواز - Turquoise (RGB: 64, 224, 208) FlashIndigo = 8519755 ' النيلي - Indigo (RGB: 75, 0, 130) FlashCoral = 5275647 ' المرجاني - Coral (RGB: 255, 127, 80) FlashSalmon = 7504122 ' السلموني - Salmon (RGB: 250, 128, 114) FlashBeige = 14480885 ' البيج - Beige (RGB: 245, 245, 220) FlashLavender = 16443110 ' الخزامى - Lavender (RGB: 230, 230, 250) End Enum ' تعداد لتحديد نوع الوميض: لون النص أو لون الخلفية Public Enum flashType FlashForeColor = 0 ' الوميض على لون النص - ForeColor FlashBackColor = 1 ' الوميض على لون الخلفية - BackColor End Enum ' دالة لجعل مربع النص يومض بلونين محددين بناءً على شرط معين ' txtBox: مربع النص الذي سيتم تطبيق الوميض عليه ' condition: الشرط الذي يحدد ما إذا كان الوميض سيتم تفعيله أم لا ' color1: اللون الأول للوميض (اختياري، الافتراضي هو FlashYellow) ' color2: اللون الثاني للوميض (اختياري، الافتراضي هو FlashRed) ' flashType: نوع الوميض (لون النص أو الخلفية، اختياري، الافتراضي هو FlashForeColor) Public Sub FlashTextBox(txtBox As TextBox, condition As Boolean, Optional color1 As FlashColors = FlashYellow, Optional color2 As FlashColors = FlashRed, Optional flashType As flashType = FlashForeColor) ' متغير ثابت لتتبع حالة الوميض (يتغير بين True وFalse) Static isFlashing As Boolean ' التحقق من تحقق الشرط If condition Then ' تحديد ما إذا كان الوميض سيطبق على لون النص أو الخلفية بناءً على flashType If flashType = FlashForeColor Then ' الوميض على لون النص If isFlashing Then txtBox.ForeColor = color1 ' تعيين اللون الأول للنص Else txtBox.ForeColor = color2 ' تعيين اللون الثاني للنص End If Else ' الوميض على لون الخلفية If isFlashing Then txtBox.BackColor = color1 ' تعيين اللون الأول للخلفية Else txtBox.BackColor = color2 ' تعيين اللون الثاني للخلفية End If End If ' عكس حالة الوميض للتبديل في المرة القادمة isFlashing = Not isFlashing ' تحديث الشاشة لعرض التغيير فوراً Application.Echo True Else ' إذا لم يتحقق الشرط، إعادة الإعدادات إلى الافتراضية If flashType = FlashForeColor Then txtBox.ForeColor = FlashBlack ' لون النص الأسود كافتراضي Else txtBox.BackColor = FlashWhite ' لون الخلفية الأبيض كافتراضي End If End If End Sub الاستدعاء ' استدعاء الدالة العامة للوميض ' txtValue هو اسم مربع النص الذي يحتوي على القيمة (مثل 5) ' txtFlash هو اسم مربع النص الذي سيمضي FlashTextBox Me.txtFlash, (Me.txtValue = "5"), FlashGold, FlashBlue ------------------------------------------------------- أو لتغير خلفية مربع النص FlashTextBox Me.txtFlash, (Me.txtValue = "5"), FlashMagenta, FlashWhite, FlashBackColor ------------------------------------------------------- أو لتغير لون الخط وهو الافتراضى كما بالكود FlashTextBox Me.txtFlash, (Me.txtValue = "5"), FlashMagenta, FlashWhite أو FlashTextBox Me.txtFlash, (Me.txtValue = "5"), FlashMagenta, FlashWhite, FlashForeColor

اتفضل يا سيدى كود الوحده النمطيه Public Sub FlashTextBox(txtBox As TextBox, condition As Boolean, Optional color1 As Long = vbYellow, Optional color2 As Long = vbRed) ' تعريف متغير للتحكم في الوميض Static isFlashing As Boolean If condition Then ' إذا تحقق الشرط (القيمة = 5)، يتم الوميض بين اللونين If isFlashing Then txtBox.BackColor = color1 ' اللون الأول (الأصفر افتراضيًا) Else txtBox.BackColor = color2 ' اللون الثاني (الأحمر افتراضيًا) End If isFlashing = Not isFlashing ' إعادة تشغيل المؤقت لاستمرار الوميض Application.Echo True Else ' إذا لم يتحقق الشرط، يظل النص ثابتًا بلون افتراضي txtBox.BackColor = vbWhite ' اللون الافتراضي End If End Sub كود الاستدعاء داخل النموذج Private Sub Form_Current() ' استدعاء الدالة العامة للوميض ' txtValue هو اسم مربع النص الذي يحتوي على القيمة (مثل 5) ' txtFlash هو اسم مربع النص الذي سيمضي FlashTextBox Me.txtFlash, (Me.txtValue = "5"), vbYellow, vbRed End Sub Private Sub Form_Timer() ' استدعاء الدالة العامة مرة أخرى لتحديث الوميض FlashTextBox Me.txtFlash, (Me.txtValue = "5"), vbYellow, vbRed End Sub يمكن تغيير الالوان كما تريد مثلا مثل Private Sub Form_Current() ' استدعاء الدالة العامة للوميض ' txtValue هو اسم مربع النص الذي يحتوي على القيمة (مثل 5) ' txtFlash هو اسم مربع النص الذي سيمضي FlashTextBox Me.txtFlash, (Me.txtValue = "5"), vbGreen, vbBlue End Sub Private Sub Form_Timer() ' استدعاء الدالة العامة مرة أخرى لتحديث الوميض FlashTextBox Me.txtFlash, (Me.txtValue = "5"), vbGreen, vbBlue End Sub او FlashTextBox Me.txtFlash, (Me.txtValue = "5") او FlashTextBox Me.txtFlash, (Me.txtValue = "5"), RGB(0, 255, 0), RGB(0, 0, 255) طبعا مع ضبط سرعة عداد الوقت كما يناسب رغباتك يا افندم طبعا انا خليتك تمرر القيمه مع الاستدعاء للمرونه علشان تنفع مع اى قيم كمان وميض (1).accdb

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

طيب اليكم المرفق الاخيـــــــــــــــــــر المميزات : الاعتماد الكامل على الرقم القومى دوال منفصلة لسهولة استدعائها فى استعلام من خلال الرقم القومى يتم استخراج الجنس/النوع استخراج مكان الميلاد استخراج تاريخ الميلاد حساب العمر بالسنوات حساب العمر بالأشهر حساب العمر بالأيام بناء على حقل تاريخ الميلاد المستخرج من الرقم القومى يتم عمل التالى حساب تاريخ التقاعد حساب سن التقاعد السنوات المتبقيه للتقاعد الاشهر المتبقيه للتقاعد الايام المتبقيه للتقاعد افتح الاستعلام فى القاعده والذى يحمل الاسم : qryAllInfoFromNationalID المرونة المطلقه فقط عند نقل الوحدات النمطية الى اى قاعدة بيانات عمل استعلام وفقط تغير اسم الحقل الخاص بالرقم القومى تبعا للمسمى الموجود فى الجدول الخاص بكم والملون هنا باللون الاحمر BirthDateFromNationalID: GetBirthDateFromNationalID([Emp_NationalID]) وباقى حقول الاستعلام جميعا تعتمد على هذا الحقل لذلك يتم نقلها كما هى ولكن ولكن ولكن لا تغير اسم الحقل : BirthDateFromNationalID لان هذا الاسم تعتمد باقى وكل الحقول الاخرى عليه اعتقد بهذا المرفق يكون الموضوع قتل بحثا وتم عمل كل ما يمكن فيه ويمكن وبكل سهولة ومرونة الان استخدام الحقول المناسبه حسب الحاجه داخل التقارير او النماذج بكل بساطه تم اضافة : نموذج : frmAllInfoFromNationalID تقريــر : rptAllInfoFromNationalID مصدر بيانات كل منهما الاستعلام : qryAllInfoFromNationalID اما النموذج : frmEmployees مصدر بياناته هو الجدول مباشرة الان القاعده كاملة و متكاملة مع تحقيق أقصى درجات المرونه المطلقة والحصول على كل البيانات الممكنه من خلال الرقم القومى مباشره سن التقاعد (8).accdb

ممكن مرفق بالمشكلة

اتفضل بيانات المدرسين (2).zip

ده كده كده لازم يكون اسرع طبعا ابشر ------------ لا اتكلم يا أخويه براحتك يا فؤش أفندى ما تخلى اى شئ فى نفسك وأكدبك ليه اذا كان أنا عراف أن مفيش دماغ أساسا يا استاذ @Foksh هههههههه مش محتاج تأكيد خالص هو بزمتك ده شئ محتاج لتأكيد أو إثبات

تقصد دماغى واللا دماغك انت ؟. انا عن نفسي عمرها ما تعمل 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