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

اثراء للموضوع ومشاركة مع احبابى واساتذتى العظماء اليكم تجميعه بأهم دوال الوقت الوتاريخ مجمعة فى وحدة نمطية عامة واحدة Public Function IsValidDate(ByVal dtDate As Date) As Boolean ' الغرض: التحقق مما إذا كان التاريخ المقدم تاريخًا صالحًا. ' الوسائط: dtDate - التاريخ المطلوب التحقق منه. ' الإرجاع: True إذا كان التاريخ صالحًا؛ وإلا False. ' مثال الاستخدام: ' If IsValidDate(txtDate) Then ' ' قم بعمل شيء ما مع التاريخ الصالح ' End If On Error Resume Next IsValidDate = IsDate(dtDate) On Error GoTo 0 End Function '1 Function FormatDate(ByVal vDate As Variant) As String ' الغرض: إرجاع سلسلة نصية بتنسيق التاريخ المستخدم بشكل طبيعي في . ' JET SQL. ' الوسيط: قيمة تاريخ/وقت. ' ملاحظة: يتم إرجاع تنسيق التاريخ فقط إذا لم يكن هناك مكون وقت، أو تنسيق التاريخ/الوقت إذا كان موجودًا. ' ' مثال الاستخدام: ' a = DLookup("[some field]", "some table", "[id]=" & Me.ID & " And [Date_Field]=" & FormatDate(The_Date_Field)) If IsDate(vDate) Then If DateValue(vDate) = vDate Then FormatDate = Format$(vDate, "\#mm\/dd\/yyyy\#") Else FormatDate = Format$(vDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#") End If End If End Function Function GetAmericanDateFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأمريكي (MM-dd-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق MM-dd-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' ' ' مثال الاستخدام: ' formattedDate = GetAmericanDateFormat(SomeDateField) If IsNull(vDate) Or vDate = vbNullString Or Len(vDate) = 0 Then GetAmericanDateFormat = Format(Date, "MM-dd-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetAmericanDateFormat = Format(CDate(vDate), "MM-dd-yyyy", vbUseSystem) Else GetAmericanDateFormat = "" End If End Function Function GetDateInEuropeanFormat(ByVal vDate As Variant) As Date ' الغرض: تنسيق قيمة التاريخ إلى التنسيق الأوروبي (dd-MM-yyyy). ' الوسيط: قيمة تاريخ/وقت أو قيمة فارغة/غير محددة. ' ملاحظة: يتم إرجاع التاريخ الحالي بتنسيق dd-MM-yyyy إذا كانت الوسيطة فارغة أو غير محددة. ' ' مثال الاستخدام: ' formattedDate = GetDateInEuropeanFormat(SomeDateField) If IsNull(vDate) Or Len(vDate) = 0 Then GetDateInEuropeanFormat = Format(Date, "dd-MM-yyyy", vbUseSystem) ElseIf IsValidDate(vDate) Then GetDateInEuropeanFormat = Format(CDate(vDate), "dd-MM-yyyy", vbUseSystem) Else GetDateInEuropeanFormat = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '2 Public Function ConvertDate(ByRef strInputDate As String, ByVal strConversionType As String) As String ' الغرض: تحويل التاريخ بين التنسيق الهجري والميلادي بناءً على نوع التحويل المحدد. ' الوسائط: strInputDate - التاريخ المراد تحويله كسلسلة نصية. ' strConversionType - نوع التحويل، "H" للتحويل من الهجري إلى الميلادي، "M" للتحويل من الميلادي إلى الهجري. ' ملاحظة: يتم تعديل التاريخ وفقًا لليوم التصحيحي من الجدول tblAdjustHjriDate. ' ' مثال الاستخدام: ' convertedDate = ConvertDate(txtHijriDate, "H") ' تحويل من الهجري إلى الميلادي ' convertedDate = ConvertDate(txtMiladyDate, "M") ' تحويل من الميلادي إلى الهجري Dim intCorrectionDay As Integer Dim intSavedCalendar As Integer Dim dtConvertedDate As Date Dim strFormattedDate As String On Error GoTo ErrorHandler ' الحصول على يوم التصحيح من الجدول intCorrectionDay = DLookup("[AdjustDay]", "tblAdjustHjriDate") ' التحقق من صحة التاريخ المدخل If IsValidDate(strInputDate) Then ' تعيين نوع التقويم وتحويل التاريخ بناءً على نوع التحويل If strConversionType = "M" Then ' الميلادي إلى الهجري strInputDate = Trim(Format(DateAdd("d", -intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 1 dtConvertedDate = CDate(strInputDate) VBA.calendar = intSavedCalendar Else ' الهجري إلى الميلادي strInputDate = Trim(Format(DateAdd("d", intCorrectionDay, strInputDate), "dd/mm/yyyy")) intSavedCalendar = VBA.calendar VBA.calendar = 0 dtConvertedDate = CDate(strInputDate) VBA.calendar = 1 End If ' تنسيق التاريخ المحول كسلسلة نصية strFormattedDate = Format(dtConvertedDate, "dd/mm/yyyy") ConvertDate = strFormattedDate Else ConvertDate = "" End If Exit Function ErrorHandler: If err.Number = 13 Then MsgBox "تنسيق تاريخ غير صالح. يرجى التحقق من البيانات المدخلة.", vbOKOnly + vbExclamation, "خطأ" Else MsgBox "حدث خطأ غير متوقع: " & err.Description, vbOKOnly + vbCritical, "خطأ" End If Exit Function End Function '----------------------------End------------------------------------------------------------------------------------------- '3 Public Function ConvertNumberToLocale(ByVal strNumber As String, ByVal strLocale As String) As String ' الغرض: تحويل الأرقام بين النظام العددي العربي والإنجليزي بناءً على اللغة المحددة. ' الوسائط: strNumber - السلسلة الرقمية المراد تحويلها. ' strLocale - نوع اللغة، "Ar" للأرقام العربية، "En" للأرقام الإنجليزية. ' ملاحظة: تقوم بتحويل الأرقام من العربية إلى الإنجليزية والعكس. ' ' مثال الاستخدام: ' txtNumberToArabic = ConvertNumberToLocale(txtNumber, "Ar") ' تحويل الأرقام الإنجليزية إلى عربية ' txtNumberToEnglish = ConvertNumberToLocale(txtNumber, "En") ' تحويل الأرقام العربية إلى إنجليزية Dim strConvertedNumber As String If strLocale = "Ar" Then ' تحويل الأرقام الإنجليزية إلى عربية strConvertedNumber = Replace(strNumber, ChrW(48), ChrW(1632)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(49), ChrW(1633)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(50), ChrW(1634)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(51), ChrW(1635)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(52), ChrW(1636)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(53), ChrW(1637)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(54), ChrW(1638)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(55), ChrW(1639)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(56), ChrW(1640)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(57), ChrW(1641)) ' 9 ElseIf strLocale = "En" Then ' تحويل الأرقام العربية إلى إنجليزية strConvertedNumber = Replace(strNumber, ChrW(1632), ChrW(48)) ' 0 strConvertedNumber = Replace(strConvertedNumber, ChrW(1633), ChrW(49)) ' 1 strConvertedNumber = Replace(strConvertedNumber, ChrW(1634), ChrW(50)) ' 2 strConvertedNumber = Replace(strConvertedNumber, ChrW(1635), ChrW(51)) ' 3 strConvertedNumber = Replace(strConvertedNumber, ChrW(1636), ChrW(52)) ' 4 strConvertedNumber = Replace(strConvertedNumber, ChrW(1637), ChrW(53)) ' 5 strConvertedNumber = Replace(strConvertedNumber, ChrW(1638), ChrW(54)) ' 6 strConvertedNumber = Replace(strConvertedNumber, ChrW(1639), ChrW(55)) ' 7 strConvertedNumber = Replace(strConvertedNumber, ChrW(1640), ChrW(56)) ' 8 strConvertedNumber = Replace(strConvertedNumber, ChrW(1641), ChrW(57)) ' 9 End If ConvertNumberToLocale = strConvertedNumber End Function '----------------------------End------------------------------------------------------------------------------------------- '4 Public Function GetMonthName(ByVal dtDate As Date, ByVal strLocale As String) As String ' الغرض: إرجاع اسم الشهر بناءً على اللغة المحددة. ' الوسائط: dtDate - التاريخ الذي يتم استخراج اسم الشهر منه. ' strLocale - نوع اللغة لتحديد لغة اسم الشهر. ' "HJ" للهجري، "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة، ' "Cpti" للقبطية، "Syr" للسريانية. ' الإرجاع: اسم الشهر باللغة المحددة. ' ' مثال الاستخدام: ' txtMonthNameHijri = GetMonthName(txtDate, "HJ") ' اسم الشهر الهجري ' txtMonthNameArabic = GetMonthName(txtDate, "Ar") ' اسم الشهر العربي ' txtMonthNameEnglish = GetMonthName(txtDate, "En") ' اسم الشهر الإنجليزي ' txtMonthNameEnglishShort = GetMonthName(txtDate, "EnShrt") ' اسم الشهر الإنجليزي المختصر ' txtMonthNameCoptic = GetMonthName(txtDate, "Cpti") ' اسم الشهر القبطي ' txtMonthNameSyriac = GetMonthName(txtDate, "Syr") ' اسم الشهر السرياني Dim strMonthName(12) As String ' التحقق من صحة اللغة المحددة If strLocale <> "HJ" And strLocale <> "Ar" And strLocale <> "En" And strLocale <> "EnShrt" And strLocale <> "Cpti" And strLocale <> "Syr" And strLocale <> "No" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'HJ'، 'Ar'، 'En'، 'EnShrt'، 'Cpti'، 'Syr'، أو 'No'.", vbExclamation, "خطأ" Exit Function End If If IsValidDate(dtDate) Then ' تحديد أسماء الأشهر لكل لغة Select Case strLocale Case "HJ" ' أسماء الأشهر الهجرية strMonthName(1) = "محرم" strMonthName(2) = "صفر" strMonthName(3) = "ربيع الأول" strMonthName(4) = "ربيع الآخر" strMonthName(5) = "جمادى الأولى" strMonthName(6) = "جمادى الآخرة" strMonthName(7) = "رجب" strMonthName(8) = "شعبان" strMonthName(9) = "رمضان" strMonthName(10) = "شوال" strMonthName(11) = "ذو القعدة" strMonthName(12) = "ذو الحجة" Case "Ar" ' أسماء الأشهر العربية strMonthName(1) = "يناير" strMonthName(2) = "فبراير" strMonthName(3) = "مارس" strMonthName(4) = "أبريل" strMonthName(5) = "مايو" strMonthName(6) = "يونيو" strMonthName(7) = "يوليو" strMonthName(8) = "أغسطس" strMonthName(9) = "سبتمبر" strMonthName(10) = "أكتوبر" strMonthName(11) = "نوفمبر" strMonthName(12) = "ديسمبر" Case "En" ' أسماء الأشهر الإنجليزية strMonthName(1) = "January" strMonthName(2) = "February" strMonthName(3) = "March" strMonthName(4) = "April" strMonthName(5) = "May" strMonthName(6) = "June" strMonthName(7) = "July" strMonthName(8) = "August" strMonthName(9) = "September" strMonthName(10) = "October" strMonthName(11) = "November" strMonthName(12) = "December" Case "EnShrt" ' أسماء الأشهر الإنجليزية المختصرة strMonthName(1) = "Jan" strMonthName(2) = "Feb" strMonthName(3) = "Mar" strMonthName(4) = "Apr" strMonthName(5) = "May" strMonthName(6) = "Jun" strMonthName(7) = "Jul" strMonthName(8) = "Aug" strMonthName(9) = "Sep" strMonthName(10) = "Oct" strMonthName(11) = "Nov" strMonthName(12) = "Dec" Case "Cpti" ' أسماء الأشهر القبطية strMonthName(1) = "Thout" strMonthName(2) = "Paope" strMonthName(3) = "Hator" strMonthName(4) = "Kiahk" strMonthName(5) = "Tobi" strMonthName(6) = "Meshir" strMonthName(7) = "Paremhat" strMonthName(8) = "Paremhou" strMonthName(9) = "Pashons" strMonthName(10) = "Paoni" strMonthName(11) = "Epip" strMonthName(12) = "Nasi" Case "Syr" ' أسماء الأشهر السريانية strMonthName(1) = "Nisan" strMonthName(2) = "Iyar" strMonthName(3) = "Sivan" strMonthName(4) = "Tammuz" strMonthName(5) = "Ab" strMonthName(6) = "Elul" strMonthName(7) = "Tishri" strMonthName(8) = "Heshvan" strMonthName(9) = "Kislev" strMonthName(10) = "Tevet" strMonthName(11) = "Shevat" strMonthName(12) = "Adar" Case "No" ' أسماء الأشهر بالأرقام strMonthName(1) = "( 01 )" strMonthName(2) = "( 02 )" strMonthName(3) = "( 03 )" strMonthName(4) = "( 04 )" strMonthName(5) = "( 05 )" strMonthName(6) = "( 06 )" strMonthName(7) = "( 07 )" strMonthName(8) = "( 08 )" strMonthName(9) = "( 09 )" strMonthName(10) = "( 10 )" strMonthName(11) = "( 11 )" strMonthName(12) = "( 12 )" End Select ' إرجاع اسم الشهر للتاريخ المحدد GetMonthName = strMonthName(Month(dtDate)) Else ' إرجاع سلسلة فارغة إذا كان التاريخ غير صالح GetMonthName = "" End If End Function '----------------------------End------------------------------------------------------------------------------------------- '5 Public Function GetDayName(ByVal dtAnyDate As Date, ByVal strLng As String) As String ' الغرض: إرجاع اسم اليوم بناءً على التاريخ واللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج اسم اليوم منه. ' strLng - نوع اللغة لاسم اليوم: ' "Ar" للعربية، "En" للإنجليزية، "EnShrt" للإنجليزية المختصرة. ' الإرجاع: اسم اليوم باللغة المحددة. ' ' مثال الاستخدام: ' txtDayNameAR = DayName(txtDate, "Ar") ' اسم اليوم بالعربية ' txtDayNameEn = DayName(txtDate, "En") ' اسم اليوم بالإنجليزية ' txtDayNameEnShrt = DayName(txtDate, "EnShrt") ' اسم اليوم بالإنجليزية المختصرة Dim strSat As String Dim strSun As String Dim strMon As String Dim strTues As String Dim strWed As String Dim strThurs As String Dim strFri As String ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetDayName = "تاريخ غير صالح" Exit Function End If ' التحقق من صحة اللغة المحددة If strLng <> "Ar" And strLng <> "En" And strLng <> "EnShrt" Then MsgBox "اللغة المحددة غير صالحة. يرجى استخدام 'Ar'، 'En'، أو 'EnShrt'.", vbExclamation, "خطأ" Exit Function End If ' تحديد أسماء الأيام بناءً على اللغة Select Case strLng Case "Ar" strSat = "السبت" strSun = "الأحد" strMon = "الاثنين" strTues = "الثلاثاء" strWed = "الأربعاء" strThurs = "الخميس" strFri = "الجمعة" Case "En" strSat = "Saturday" strSun = "Sunday" strMon = "Monday" strTues = "Tuesday" strWed = "Wednesday" strThurs = "Thursday" strFri = "Friday" Case "EnShrt" strSat = "Sat" strSun = "Sun" strMon = "Mon" strTues = "Tue" strWed = "Wed" strThurs = "Thu" strFri = "Fri" End Select ' إرجاع اسم اليوم بناءً على يوم الأسبوع للتاريخ المحدد GetDayName = Choose(Weekday(dtAnyDate), strSun, strMon, strTues, strWed, strThurs, strFri, strSat) End Function '----------------------------End------------------------------------------------------------------------------------------- '6 Public Function NumofDays(ByVal dtAnyDate As Date) As Integer ' الغرض: إرجاع عدد الأيام في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج عدد الأيام في شهره. ' الإرجاع: عدد الأيام في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtNumofDaysMonth = NumofDays(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial ' ثم إرجاع جزء اليوم من ذلك التاريخ، والذي يمثل العدد الإجمالي للأيام في ذلك الشهر. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" NumofDays = -1 ' إرجاع قيمة غير صالحة للإشارة إلى خطأ Exit Function End If NumofDays = Day(DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0)) End Function '----------------------------End------------------------------------------------------------------------------------------- '7 Public Function GetLastDayInMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayInMonth = GetLastDayInMonth(txtDate) ' حساب آخر يوم في الشهر الحالي باستخدام الدالة DateSerial. ' تقوم هذه الدالة بإنشاء تاريخ مع السنة والشهر من التاريخ المحدد وتعيين اليوم إلى 0، ' مما يعطينا بشكل فعال آخر يوم في الشهر السابق، أي آخر يوم في الشهر الحالي. ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayInMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If GetLastDayInMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '8 Public Function GetFirstDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في شهره. ' الإرجاع: أول يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfMonth = GetFirstDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' حساب أول يوم في الشهر الحالي باستخدام الدالة DateSerial GetFirstDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '9 Public Function GetFirstDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر التالي له. ' الإرجاع: أول يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfNextMonth = GetFirstDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر التالي باستخدام الدالة DateSerial GetFirstDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '10 Public Function GetFirstDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع أول يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج أول يوم في الشهر السابق له. ' الإرجاع: أول يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtFirstDayOfPreviousMonth = GetFirstDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetFirstDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع أول يوم في الشهر السابق باستخدام الدالة DateSerial GetFirstDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) - 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- '11 Public Function GetLastDayOfMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في شهر التاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في شهره. ' الإرجاع: آخر يوم في شهر التاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfMonth = GetLastDayOfMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر باستخدام الدالة DateSerial GetLastDayOfMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '12 Public Function GetLastDayOfNextMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر التالي للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر التالي له. ' الإرجاع: آخر يوم في الشهر التالي للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfNextMonth = GetLastDayOfNextMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfNextMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر التالي باستخدام الدالة DateSerial GetLastDayOfNextMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 2, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '13 Public Function GetLastDayOfPreviousMonth(ByVal dtAnyDate As Date) As Date ' الغرض: إرجاع آخر يوم في الشهر السابق للتاريخ المحدد. ' الوسائط: dtAnyDate - التاريخ الذي يتم استخراج آخر يوم في الشهر السابق له. ' الإرجاع: آخر يوم في الشهر السابق للتاريخ المحدد. ' ' مثال الاستخدام: ' txtLastDayOfPreviousMonth = GetLastDayOfPreviousMonth(txtDate) ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" GetLastDayOfPreviousMonth = CDate("0001-01-01") ' إرجاع تاريخ غير صالح للإشارة إلى خطأ Exit Function End If ' إرجاع آخر يوم في الشهر السابق باستخدام الدالة DateSerial GetLastDayOfPreviousMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 0) End Function '----------------------------End------------------------------------------------------------------------------------------- '14 Public Function TimeByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع الوقت بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ/الوقت الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = TimeByLanguage(txtDateTime, "Ar") ' الوقت بالعربية ' txtTimeEnglish = TimeByLanguage(txtDateTime, "En") ' الوقت بالإنجليزية ' التحقق من أن dtAnyDate تاريخ/وقت صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا/وقتًا صالحًا. يرجى إدخال تاريخ/وقت صحيح.", vbExclamation, "تاريخ/وقت غير صالح" TimeByLanguage = "تاريخ/وقت غير صالح" Exit Function End If ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت إلى العربية واستبدال AM/PM بالنصوص العربية TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM TimeByLanguage = ConvertNumberToLocale(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة TimeByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '15 Public Function GetLocalizedTimeString(ByVal strLng As String) As String ' الغرض: إرجاع الوقت الحالي بتنسيق اللغة المحددة. ' الوسائط: strLng - اللغة المحددة لتنسيق الوقت ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: الوقت الحالي بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtTimeArabic = GetLocalizedTimeString("Ar") ' الوقت الحالي بالعربية ' txtTimeEnglish = GetLocalizedTimeString("En") ' الوقت الحالي بالإنجليزية ' تعريف نصوص AM وPM للغة العربية Dim strAm As String: strAm = "صباحًا " Dim strPm As String: strPm = "مساءً " ' تنسيق الوقت بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل الوقت الحالي إلى العربية واستبدال AM/PM بالنصوص العربية GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), "AM", strAm), "PM", strPm), "Ar") Case "En" ' تحويل الوقت الحالي إلى الإنجليزية واستبدال النصوص العربية بـ AM/PM GetLocalizedTimeString = ConvertNumberToLocale(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), strAm, "AM"), strPm, "PM"), "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة GetLocalizedTimeString = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- '16 Public Function FormatDateByLanguage(ByVal dtAnyDate As Variant, ByVal strLng As String) As String ' الغرض: إرجاع التاريخ بتنسيق اللغة المحددة. ' الوسائط: dtAnyDate - التاريخ الذي يتم تنسيقه. ' strLng - اللغة المحددة لتنسيق التاريخ ("Ar" للعربية، "En" للإنجليزية). ' الإرجاع: التاريخ بتنسيق اللغة المحددة. ' ' مثال الاستخدام: ' txtDateArabic = FormatDateByLanguage(txtDate, "Ar") ' التاريخ بالعربية ' txtDateEnglish = FormatDateByLanguage(txtDate, "En") ' التاريخ بالإنجليزية ' التحقق من أن dtAnyDate تاريخ صالح If Not IsDate(dtAnyDate) Then MsgBox "الإدخال ليس تاريخًا صالحًا. يرجى إدخال تاريخ صحيح.", vbExclamation, "تاريخ غير صالح" FormatDateByLanguage = "تاريخ غير صالح" Exit Function End If ' تنسيق التاريخ بناءً على اللغة المحددة Select Case strLng Case "Ar" ' تحويل التاريخ إلى العربية وإضافة رمز "م" (لتحديد التقويم الميلادي) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "م ", "Ar") Case "En" ' تحويل التاريخ إلى الإنجليزية وإضافة رمز "هـ" (لتحديد التقويم الهجري) FormatDateByLanguage = ConvertNumberToLocale(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & "هـ ", "En") Case Else ' إرجاع رسالة خطأ إذا كانت اللغة غير مدعومة FormatDateByLanguage = "اللغة غير مدعومة" End Select End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetFirstDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع أول يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: أول يوم في السنة المحددة (1 يناير). ' ' مثال الاستخدام: ' txtFirstDayOfYear = GetFirstDayOfYear(2023) ' أول يوم في سنة 2023 ' txtFirstDayOfYear = GetFirstDayOfYear() ' أول يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع أول يوم في السنة (1 يناير) GetFirstDayOfYear = DateSerial(ReferenceYear, 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- Public Function GetLastDayOfYear(Optional ReferenceYear As Integer = 0) As Date ' الغرض: إرجاع آخر يوم في السنة المحددة. ' الوسائط: ReferenceYear - السنة المرجعية (اختياري، إذا لم يتم تحديدها، يتم استخدام السنة الحالية). ' الإرجاع: آخر يوم في السنة المحددة (31 ديسمبر). ' ' مثال الاستخدام: ' txtLastDayOfYear = GetLastDayOfYear(2023) ' آخر يوم في سنة 2023 ' txtLastDayOfYear = GetLastDayOfYear() ' آخر يوم في السنة الحالية ' تحديد السنة المرجعية If ReferenceYear = 0 Then ReferenceYear = Year(Now) ' استخدام السنة الحالية إذا لم يتم تحديد سنة مرجعية End If ' إرجاع آخر يوم في السنة (31 ديسمبر) GetLastDayOfYear = DateSerial(ReferenceYear, 12, 31) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب الفرق بين تاريخين (بالأيام، الأشهر، السنوات) Public Function GetDateDifferenceInDays(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأيام. GetDateDifferenceInDays = DateDiff("d", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInMonths(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالأشهر. GetDateDifferenceInMonths = DateDiff("m", dtStartDate, dtEndDate) End Function Public Function GetDateDifferenceInYears(ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Long ' الغرض: حساب الفرق بين تاريخين بالسنوات. GetDateDifferenceInYears = DateDiff("yyyy", dtStartDate, dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' إضافة أو طرح أيام/أشهر/سنوات من تاريخ معين Public Function AddDaysToDate(ByVal dtDate As Date, ByVal intDays As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأيام من تاريخ معين. AddDaysToDate = DateAdd("d", intDays, dtDate) End Function Public Function AddMonthsToDate(ByVal dtDate As Date, ByVal intMonths As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من الأشهر من تاريخ معين. AddMonthsToDate = DateAdd("m", intMonths, dtDate) End Function Public Function AddYearsToDate(ByVal dtDate As Date, ByVal intYears As Integer) As Date ' الغرض: إضافة أو طرح عدد محدد من السنوات من تاريخ معين. AddYearsToDate = DateAdd("yyyy", intYears, dtDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' التحقق مما إذا كان تاريخ معين ضمن نطاق تاريخين Public Function IsDateInRange(ByVal dtDate As Date, ByVal dtStartDate As Date, ByVal dtEndDate As Date) As Boolean ' الغرض: التحقق مما إذا كان تاريخ معين يقع بين تاريخين محددين. IsDateInRange = (dtDate >= dtStartDate And dtDate <= dtEndDate) End Function '----------------------------End------------------------------------------------------------------------------------------- ' حساب العمر بناءً على تاريخ الميلاد Public Function CalculateAge(ByVal dtBirthDate As Date) As Integer ' الغرض: حساب العمر بالسنوات بناءً على تاريخ الميلاد. CalculateAge = DateDiff("yyyy", dtBirthDate, Now) If DateSerial(Year(Now), Month(dtBirthDate), Day(dtBirthDate)) > Now Then CalculateAge = CalculateAge - 1 End If End Function '----------------------------End------------------------------------------------------------------------------------------- ' تحديد عدد الأيام منذ تاريخ معين Public Function GetDaysSinceDate(ByVal dtStartDate As Date) As Integer ' الغرض: حساب عدد الأيام المنقضية منذ تاريخ معين. GetDaysSinceDate = DateDiff("d", dtStartDate, Now) End Function '----------------------------End-------------------------------------------------------------------------------------------

تفضل أخي @al.sheen2000 دوال أول يوم بالشهر .... وآخر يوم بالشهر .... وأول يوم بالسنة .... وآخر يوم بالسنة . Private Sub BtnChangeDate_Click() If Len(Me.Txt1 & "") = 0 Then MsgBox "أدخل التاريخ " Undo Me.Txt1.SetFocus Exit Sub Else 'أول يوم بالشهر Me.Txt2 = DateSerial(Year(Me.Txt1), Month(Me.Txt1), 1) 'آخر يوم بالشهر Me.Txt3 = DateSerial(Year(Me.Txt1), Month(Me.Txt1) + 1, 0) Dim inputDate As Date Dim inputYear As Integer Dim lastDayOfYear As Date Dim firstDayOfYear As Date inputDate = CDate(Me.Txt1.Value) inputYear = Year(inputDate) ' Extract the year from the date 'أول يوم بالسنة firstDayOfYear = DateSerial(inputYear, 1, 1) ' Calculate the first day of the year Me.Txt4.Value = firstDayOfYear 'آخر يوم بالسنة lastDayOfYear = DateSerial(inputYear, 12, 31) ' Calculate the last day of the year Me.Txt5.Value = lastDayOfYear End If End Sub

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كثير منا يبحث عن QR ( رمز إستجابة سريعة ) ولكن ملوّن !! ونستطيع التحكم باللون حسب حاجته !! اليوم بطريقة بسيطة يتم تنفيذها بكل سلاسة سنحقق ذلك . والفائدة على سبيل المثال :- الإبتعاد عن النمط التقليدي اللون الأسود المعروف به رمز الـ QR .. شكل جمالي ملفت لرمز الإستجابة QR .. التمييز بين الأقسام أو الأستخدام للـ QR حسب حاجة المشروع . فمثلاً ( قسم المحاسبة لهم رمز باللون الأزرق ، قسم الصيانة لهم رمز باللون الأسود ، المعلمين رمز باللون الأحمر ..... إلخ . والكثير من الإستخدامات التي لا تخطر ببالي حالياً . تأكد من تثبيت إصدار NET Framework 4.0 أو أعلى على جهازك . تستطيع التحميل من هذا الرابط ، أو بشكل مباشر من هذا الرابط . برنامج ImageMagick . ويمكنك تحميله من رابط الموقع من هذا الرابط ، أو بشكل مباشر من هذا الرابط . ملفات الـ DLL ( zxing.interop.dll ، zxing.dll ، zxing.interop.tlb ) والتي هي مكتبات سيتم إضافتها الى محرر الأكواد VBA في آكسيس لاحقاً طريقة التثبيت والإضافة ( موجودة في الملف المرفق ) . أولا يلزمنا تسجيل المكتبات المستخدمة في المشروع ( وهنا سنستخدم ZXing لتنفيذ مهمتنا ) وطبعاً سنحتاج مكتبة QRCode ، ويجب تسجيلها ليتم إضافتها في آكسيس في مكتبات الـ VBA > Tools > References . فكيف ننفذ هذه الخطوة المهمة . بعد التأكد من تثبيت المستلزمين السابقين :- افتح موجه الأوامر CMD كمسؤول ( Run as Administrator ) . قم بكتابة السطر التالي لتسجيل المكتبة :- cd C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك قم بكتابة السطر التالي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase zxing.interop.dll ومن المفترض أن تظهر معك النتيجة بهذا الشكل :- أما خلاف ذلك فأن عملية تسجيل المكتبة لم تنجح ولن يتم إضافتها إلى محرر الأكواد VBA كما نريد . الآن لاستكمال عملية تسجيل المكتبة وإضافتها الى محرر الأكواد VBA ، نطبق آخر خطوة وهي :- C:\Windows\Microsoft.NET\Framework64\v4.0.30319\regasm.exe /codebase "C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.dll" /tlb:"C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\zxing.interop.tlb" --------------------- حيث هنا ، المسار C:\Users\Golden\Desktop\QR\QrCodeZXing\ZXing_Library\ Dll مسار المجلد الذي يحتوي ملفات الـ التي تحدثنا عنها من ضمن المستلزمات ، وسيكون متغيراً حسب جهازك الآن نفتح قاعدة بيانات جديدة ، ونذهب إلى محرر الأكواد ( Tools > References ) ، ونبحث عن المكتبة التالية كما في الصورة :- الآن وبعد إتمام عملية التسجيل للمكتبة المطلوبة وتثبيت المستلزمات السابقة ، نقوم بإنشاء نموذج يحتوي على مربع نص ، وعنصر صورة ، و زر لتنفيذ العملية . ثم نأتي إلى الأكواد ، وما سنحتاجه الآن هو مديول يحتوي على الدالتين التاليتين :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit #If VBA7 Then Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Function Encode_To_QR_Code_To_File(str As String, Optional foregroundColor As String = "black", Optional backgroundColor As String = "white") As String On Error GoTo ErrorHandler Dim writer As IBarcodeWriter Dim qrCodeOptions As QrCodeEncodingOptions Dim filepath As String Dim folderPath As String folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If filepath = folderPath & "\QRCode_" & Format(Now, "yyyyMMdd_hhmmss") & ".png" Set qrCodeOptions = New QrCodeEncodingOptions Set writer = New BarcodeWriter writer.Format = BarcodeFormat_QR_CODE Set writer.Options = qrCodeOptions qrCodeOptions.Height = 200 qrCodeOptions.Width = 200 qrCodeOptions.CharacterSet = "UTF-8" qrCodeOptions.Margin = 1 qrCodeOptions.ErrorCorrection = ErrorCorrectionLevel_H writer.WriteToFile str, filepath, ImageFileFormat_Png If Change_QR_Code_Colors_ImageMagick(filepath, foregroundColor, backgroundColor) Then Encode_To_QR_Code_To_File = filepath Else Encode_To_QR_Code_To_File = "" End If Exit Function ErrorHandler: Encode_To_QR_Code_To_File = "" MsgBox "حدث خطأ أثناء إنشاء QR Code: " & Err.Description, vbCritical, "خطأ" End Function Function Change_QR_Code_Colors_ImageMagick(filepath As String, foregroundColor As String, backgroundColor As String) As Boolean On Error GoTo ErrorHandler Dim batchFilePath As String Dim batchContent As String Dim result As Long If Dir(filepath) = "" Then MsgBox "لم يتم العثور على الملف: " & filepath, vbCritical, "خطأ" Exit Function End If batchContent = "@echo off" & vbCrLf & "magick " & Chr(34) & filepath & Chr(34) & " -fill " & foregroundColor & " -opaque black -fill " & backgroundColor & " -opaque white " & Chr(34) & filepath & Chr(34) batchFilePath = Environ$("temp") & "\ChangeQRColors.bat" Open batchFilePath For Output As #1 Print #1, batchContent Close #1 result = Shell("powershell -Command Start-Process " & Chr(34) & batchFilePath & Chr(34) & " -Verb RunAs", vbHide) DoEvents Sleep 3000 If Dir(filepath) <> "" Then Change_QR_Code_Colors_ImageMagick = True Else Change_QR_Code_Colors_ImageMagick = False End If Kill batchFilePath Exit Function ErrorHandler: Change_QR_Code_Colors_ImageMagick = False MsgBox "حدث خطأ أثناء تغيير ألوان QR Code: " & Err.Description, vbCritical, "خطأ" End Function وفي حدث عند النقر لزر التنفيذ ، الكود التالي :- Private Sub Command20_Click() Dim imagePath As String Dim folderPath As String If IsNull(Me.Text0) Or Me.Text0 = "" Then MsgBox "QR Code الرجاء إدخال نص لإنشاء", vbExclamation, "" Exit Sub End If Dim foregroundColor As String Dim backgroundColor As String foregroundColor = "Blue" backgroundColor = "white" imagePath = Encode_To_QR_Code_To_File(Me.Text0, foregroundColor, backgroundColor) If imagePath <> "" Then Me.Image0.Picture = imagePath MsgBox " بنجاح QR Code تم إنشاء", vbInformation, "" folderPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "QRImage" Else MsgBox "فشل في إنشاء QR Code", vbCritical, "" End If End Sub الآن لتغيير ألوان الـ QR كخلفية أو لون الرمز نفسه ، تستطيع التعديل من خلال السطرين التاليين في زر التنفيذ :- foregroundColor = "Blue" <---- هنا لون الرمز نفسه backgroundColor = "white" <---- هنا لون الخلفية وهنا نكون قد وضحنا المطلوب وطريقة تنفيذه خطوة بخطوة .. QrCodeZXing.zip

السلام عليكم تحياتي للجميع فضلا لديه مربع نص يوجد في تاريخ اريد دالة تعطي اول ايام في الشهر المدخل في مربع النص . مثال ولنفرض ان عندي تاريخ ١٥/١١/٢٠٢٤ اريد تعطي ١/١١/٢٠٢٤ اشكر الجميع

السلام عليكم اتفضل اخى @ازهر عبد العزيز ويجب تغير الحقول لحقول نصيه وهذا بناء ع معرفتى والله اعلى واعلم بالتوفيق rm_1.accdb

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

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. وستلاحظون اني استخدمت الدالة DateSerial ، حتى اعطي اليوم والشهر والسنة بياناتهم يدويا ، بدلا عن استعمال CDate . هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

مشاركة مع الأستاذ خليفة .. هذه الدالة تعيد لك تاريخ أول يوم في الشهر الحالي :- =DateSerial(Year(Date()),Month(Date()),1)

جزاك الله خيرا أستاذنا الفاضل وبارك لك وكل عام وحضرتك بخير