04-10-23, 11:44 PM
الاخوة الكرام
السلام عليكم ورحمة وبركاته
الذكاء الصناعي كتب لي هذه الخوارزمية تحويل التاريخ الميلادي الى تاريخ هجري
السؤال هنا
كيف استخدم هذه الخوارزمية في برنامجي نامل المساعدة العاجله؟
نامل المساعدة وجزكم الله خيراً
السلام عليكم ورحمة وبركاته
الذكاء الصناعي كتب لي هذه الخوارزمية تحويل التاريخ الميلادي الى تاريخ هجري
السؤال هنا
كيف استخدم هذه الخوارزمية في برنامجي نامل المساعدة العاجله؟
كود :
Function GregorianToUmmAlQura(ByVal gDay As Integer, ByVal gMonth As Integer, ByVal gYear As Integer) As Variant
' إنشاء مصفوفة لحفظ التاريخ الهجري
Dim hDate(2) As Integer
' إنشاء مصفوفة ثنائية لحفظ جدول المعادلات
' كل صف يحتوي على خمسة أعمدة: رقم الشهر الهجري، رقم الشهر الميلادي، رقم السنة الميلادية، عدد أيام الشهر، فارق الأيام بين التاريخ الميلادي والهجري
Dim table(1749, 4) As Integer
' إضافة قيم جدول المعادلات
table(0, 0) = 1: table(0, 1) = 7: table(0, 2) = 1937: table(0, 3) = 29: table(0, 4) = -11237
table(1, 0) = 2: table(1, 1) = 8: table(1, 2) = 1937: table(1, 3) = 30: table(1, 4) = -11208
table(2, 0) = 3: table(2, 1) = 9: table(2, 2) = 1937: table(2, 3) = 29: table(2, 4) = -11178
' ... وهكذا حتى نهاية الجدول
' حساب رقم الشهر الميلادي منذ يناير سنة 1900
Dim gMonthNumber As Long
gMonthNumber = DateDiff("m", #1/1/1900#, DateSerial(gYear, gMonth, gDay))
' حساب رقم الشهر الميلادي منذ يوليو سنة 1937 (بداية جدول المعادلات)
Dim gMonthNumberFromTableStart As Long
gMonthNumberFromTableStart = gMonthNumber - DateDiff("m", #1/1/1900#, #7/1/1937#)
' البحث في الجدول عن الصف المناسب للتاريخ الميلادي المدخل
Dim i As Integer
For i = 0 To 1749
If gMonthNumberFromTableStart = table(i, 1) + (table(i, 2) - 1937) * 12 Then
' تحديد رقم الشهر الهجري
hDate(1) = table(i, 0)
' تحديد رقم السنة الهجرية
hDate(2) = 1356 + i \ 12
' تحديد رقم اليوم الهجري
hDate(0) = gDay + table(i, 4)
' التحقق من عدم تجاوز رقم اليوم عدد أيام الشهر
If hDate(0) > table(i, 3) Then
hDate(0) = hDate(0) - table(i, 3)
hDate(1) = hDate(1) + 1
If hDate(1) > 12 Then
hDate(1) = 1
hDate(2) = hDate(2) + 1
End If
End If
Exit For ' الخروج من حلقة التكرار بعد إيجاد الصف المناسب
End If
Next i
' إرجاع التاريخ الهجري كمصفوفة
GregorianToUmmAlQura = hDate
End Function
إذا ضاقت بك الأحوال يوماً فَثِقْ بالواحِدِ الفَرْدِ العَلِيِّ