تحدي برمجي لمحبي البرمجة مع دوال تقويم أم القرى

[عبدالله سليمان]

تحدي برمجي لمحبي البرمجة مع دوال تقويم أم القرى

عند عملي على الدوال التحويلية الخاصة بتقويم أم القرى المعد من الأخوين أبو هادي وحارث .

خطر على بالي فكرة ستكون بإذن الله حلاً لمشاكل تاريخ أم القرى مع الدوال التاريخية في الأكسس والتي لاتعطي نتائج صحيحة .

والفكرة باختصار هي عمل دوال تاريخية خاصة بتقويم أم القرى بنفس اسم الدوال التاريخية في الاكسس مع إضافة رقم (2) للاسم ، وبنفس الوسائط والوظائف .

ولله الحمد جرى إعداد الدوال التالية ( Date() – Day() – Month() – Year() - CDate – Weekday ) ( يوجد مثال لم أتمكن من إرفاقه ) .

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

الدالة الأولى : DateAdd

الدالة الثانية : DateDiff

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

وقد تبين لي أن مايكروسوفت في الاكسل تستخدم ( التاريخ كأرقام من متسلسلة متتالية حتى يمكن استخدامها في العمليات الحسابية. افتراضياً, يكون 1-1- 1900 هو رقم تسلسلي من 1, وتاريخ 1-1- 2008 هو رقم تسلسلي من 39448 لأنه يوجد 39,448 يوم بعد 1 يناير، 1900)

أرجو من المبرمجين المحترفين في المنتدى المساعدة في إعداد هاتين الدالتين لتقويم أم القرى لأهميتهما الشديدة ( خاصة دالة DateDiff ) .

[عبدالله سليمان]

تم برمجة الدالة : DateSerial2

بالكود التالي :

Public Function DateSerial2(Y_UM, M_UM, D_UM) As String
Dim da As Date
Dim da2 As String
Dim M_UM2
Dim D_UM2
Dim DATE2

da2 = Test(Y_UM & " " & M_UM & " " & D_UM)
If da2 <> "" Then
    DateSerial2 = da2
    Exit Function
End If
'حساب الشهور وإضافة سنة إن لزم
If M_UM > 12 Then
     M_UM2 = M_UM
     M_UM = Int(M_UM / 12)
     M_UM2 = M_UM2 - (M_UM * 12)
    If M_UM2 = 0 Then
        M_UM2 = 12
        M_UM = M_UM - 1
    End If

Y_UM = Y_UM + M_UM
M_UM = M_UM2
da2 = Test(Y_UM & " " & M_UM & " " & D_UM)
    If da2 <> "" Then
        DateSerial2 = da2
        Exit Function
    End If
End If

If D_UM > 29 Then
    da = CDate(Um2Greg(29, M_UM, Y_UM))
    D_UM2 = D_UM - 29
    da = DateSerial(Year(da), Month(da), Day(da) + D_UM2)

    DATE2 = Greg2Um(Day(da), Month(da), Year(da))

    DateSerial2 = Format((Year(DATE2)), "0000") & "/" & _
    Format((Month(DATE2)), "00") & "/" & Format((Day(DATE2)), "00")

End If

End Function

وبقي برمجة الدالتين :

الدالة الأولى : DateAdd

الدالة الثانية : DateDiff

علماً أنه في قاعدة البيانات يتم تخزين تاريخ أم القرى كنص ولايتم تخزين التاريخ الميلادي .

المثال موجود على الرابط التالي :

دوال تاريخ أم القرى

تم تعديل سبتمبر 9, 2004 بواسطه عبدالله سليمان

[أبوسليمان]

الأخ عبدالله سليمان

جزاك الله خيرًا

رغبت الاستفادة من عملك والاطلاع على الأكواد

غير أني لم أتمكن من تنزيل الملف المرفق

ارجوا مراجعة الرابط ولك مني خالص الشكر

أخوك أبوسليمان

تم تعديل سبتمبر 9, 2004 بواسطه أبوسليمان

[عبدالله سليمان]

الأخ / أبو سليمان

إذا لم اتمكن من إرفاق الملف في المنتدى ، فسأرسل لك المثال عبر البريد الالكتروني - إن أمكن ذلك - إن شاء الله .

لقد تم الانتهاء من برمجة الدالة DateAdd بالكود التالي :

Public Function DateAdd2(interval, add, date_um As String) As String
Dim da2 As String

da2 = Test(date_um)
If da2 = "" Then Exit Function
add = Nz(add)
Select Case interval
Case "yyyy"
DateAdd2 = DateSerial2((CLng(Left(da2, 4))) + add, Mid(da2, 6, 2), Right(da2, 2))
Case "q"
add = add * 4
DateAdd2 = DateSerial2(Left(da2, 4), (CLng(Mid(da2, 6, 2))) + add, Right(da2, 2))
Case "m"
DateAdd2 = DateSerial2(Left(da2, 4), (CLng(Mid(da2, 6, 2))) + add, Right(da2, 2))
Case "d"
DateAdd2 = DateSerial2(Left(da2, 4), Mid(da2, 6, 2), (CLng(Right(da2, 2)) + add))
Case "ww"
add = add * 7
DateAdd2 = DateSerial2(Left(da2, 4), Mid(da2, 6, 2), CLng(Right(da2, 2) + add))
End Select


End Function

طبعاً الكود البرمجي ما هو بزي اللي يسويه المحترفين ، بس إن شاء الله يؤدي الغرض بكفأة .

وبقي برمجة الدالة DateDiff ، وجاري العمل عليها .

[أبوسليمان]

شكرًا لك أخي عبدالله

وهذا بريدي بارك الله فيك

kmd_202@yahoo.com

[أبو هادي]

السلام عليكم

هذه دالة DateSerial بدقة 100% تحتاج إلى اختباراتكم .

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

Public Function DateSerial2(ByVal yy As Integer, _
                            ByVal mm As Integer, _
                            ByVal dd As Integer) As Variant
  Dim GregDate As Long
  Dim Days As Long
  Dim CurrCal As Byte
  
  Call LoadUmAlQura_Code
  DateSerial2 = Null
  
  CurrCal = Calendar
  Calendar = vbCalHijri
  Days = DateSerial(yy, mm, dd)
  If Year(Days - 0) < LBound(UmAll) Or _
     Year(Days + 1) > UBound(UmAll) Then
     Calendar = CurrCal
     Exit Function
  End If
  Calendar = vbCalGreg
  
  Do While mm < 1:  mm = mm + 12: yy = yy - 1: Loop
  Do While mm > 12: mm = mm - 12: yy = yy + 1: Loop
  
  GregDate = Nz(Um2Greg(1, mm, yy)) + dd - 1
  dd = Day(GregDate)
  mm = Month(GregDate)
  yy = Year(GregDate)
  
  If Not IsNull(Greg2Um(dd, mm, yy)) Then
   'DateSerial2 = GregDate              '-- لإعادة السيريال كرقم --'
    DateSerial2 = Greg2Um(dd, mm, yy)   '-- لإعادة السيريال كنص --'
  End If

  Calendar = CurrCal
End Function

تحياتي .

[عبدالله سليمان]

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

لكني لم أفهم ما تقصده بعبارة ( أن كل دوال أم القرى عند تصميمها لم يراعى فيها قواعد البيانات التي تستخدم التقويم الهجري )

أرجو إيضاح المقصود حتى لانقع في المحذور لأني سأستخدم هذه الدوال في قاعدة بيانات مهمة ، وسأجرب الكود الذي وضعته .

أخيراً أرجو أن تتطلع أنت والأخ / أبو سليمان وبقية المهتمين بالموضوع على المثال الموجود على الرابط أدناه :

مثال دوال أم القرى ، يجب تحويل ملحق الملف من txt إلى zip

[أبوسليمان]

الأستاذ/ عبدالله سلميان

قمت بتنزيل الملف المرفق

وجزاك الله ألف خير على هذا الجهد المبارك

وفقك الله وحفظك من كل سوء

أخوك

أبوسليمان

[عبدالله سليمان]

الأخ / أبو هادي

لقد جربت الدالة وعملت بشكل صحيح (y) ، وإن جاء التاريخ بتنسيق عكسي ( من اليسار لليمين ) .

وقد أضفت الدالة إلى المثال الذي قمت بإعداده بشكل منفصل .

والصراحة الكود ما شاء الله عليك جاي مرتب ، فيا ليت تشوف لنا باقي الدوال التاريخية .

المثال بعد الإضافة موجود في الملف الملحق .

وشكراً للأخوة المشرفين في المنتدى :d

الملفات المرفقة

دوال_تقويم_أم_القرى.zip ( 81.24ك ) عدد مرات التنزيل: 130

تم تعديل يناير 23, 2005 بواسطه أبو هادي

[أبو هادي]

السلام عليكم

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

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

أرجو إيضاح المقصود حتى لانقع في المحذور لأني سأستخدم هذه الدوال في قاعدة بيانات مهمة

الحقيقة أني دائما استخدم التقويم الميلادي وأقوم بكتابة كل الأكواد في بيئة هذا التقويم دون إي اعتبار لاستخدام التقويم الهجري من قبل الآخرين . وحيث لا يخفى عليكم أن نتائج كثير من دوال التاريخ ستعطي نتائج حسب التقويم المستخدم فمثلا دالة Year لو استخدمت لتاريخ اليوم فستعطي للميلادي 2004 وللهجري 1425 ، عليه فأني أنصح باستخدام التالي للإحتراز :

 Call LoadUmAlQura_Code

 CurrCal = Calendar
 Calendar = vbCalGreg
   '-- البداية من هنا
   '
   '
   '-- النهاية
 Calendar = CurrCal

وإن جاء التاريخ بتنسيق عكسي ( من اليسار لليمين ) .

يمكن استخدام دالة Hijri_Arabic للتنسيق العربي ( يمين إلى اليسار ) .

أعجبني كثيرا استغلالك الحميد للكود المستخدم في دالة Test حيث مهمتها الآن مطلوبة بقوة بعد ان كانت فقط لفحص المدخلات عن طريق صناديق النصوص .

تحياتي .

تم تعديل سبتمبر 10, 2004 بواسطه أبو هادي

[أبوسليمان]

الأستاذ/ الفاضل عبدالله سليمان

سعدت كثيرًا بهذه الدوال والتي سوف تخفف كثيرًا إضافة إلى جهد الأستاذ أبو هادي والحارث وغيرهم في

وضع التقويم الهجري حسب تقويم أم القرى

ملاحظة :

أخي العزيز :

في المرفق الثاني وضعت زر باسم (الانتقال إلى دوال أبو سليمان)

حتمًا أنت لا تقصدني فليس لي أي جهد يذكر في هذه الدوال

وإنما الجهد هو جهدك أخي الكريم

ولعلك تكنى بأبي سليمان كذلك

ورفعًا للحرج أحببت التنويه

كما أرجو تعديل عبارة الزر إلى ( الانتقال إلى دوال عبدالله سليمان)

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

Public Function MonthName2(da As Byte) As String
Dim mo As Byte
If da < 1 Or da > 12 Then Exit Function
da = Int(da)

Dim CurrCal As Byte
 CurrCal = Calendar
 Calendar = vbCalHijri

 MonthName2 = MonthName(da)
 Calendar = CurrCal

End Function

ودالة أسماء الأيام

Case "dddd", "ddd", "ddddd"
day_nu = Weekday2(da2, 7)
    
    format2 = Choose(day_nu, "السبت", "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة")

وتقبل فائق تحياتي أخي

[عبدالله سليمان]

الأخ أبو هادي :

ألا يمكن الاكتفاء بدوال أم القرى التحويلة عن استخدام Calendar vbCalHijri مع استخدام التقويم الميلادي في قاعدة البيانات ومنع المتسخدم من تعديله وتخزين تاريخ أم القرى كنص في قاعدة البيانات .

الأخ أبو سليمان فعلاً أنا أكنى بأبي سليمان أيضاً .

وشكراً على التنويه ..

علماً بأن دالة : DateSerial2 التي قمت أنا بإعدادها توجد بها مشاكل عندما تكون الوسائط الممرة صفر أو عدد سالب . كما أن دالة أبو هادي تتوقف عن العمل عندما يكون عدد السنوات الممر كبيراً جداً وهذا لايحصل في الواقع العملي .

لذلك فقد قمت باستبدالها بدالة الأخ أبو هادي .

ولا يخفى أن تقويم أم القرى المعد من الأخ / أبو هادي محصور بين عامي 1300 و 1450 .

وأشكرك على التعديلات التي اختصرت الكود وسأضيفها إلى المثال بعد تعديله ، ودائماً أفضل اختصار الكود ما أمكن ذلك .

كما أرجو منك ومن الأخ أبو هادي إلقاء نظرة على بقية الدوال وخاصة الدالة DateDiff .

وأرجو منكما أيضاً ومن بقية المهتمين بتقويم أم القرى الإطلاع على هذا الرابط :

http://www.fahrasi.com/salrash.html

و

تم تعديل سبتمبر 11, 2004 بواسطه عبدالله سليمان

[أبوسليمان]

الأستاذ / أبوسليمان عبدالله سليمان

سلام الله عليك ورحمته وبركاته وبعد

أشكرك بالغ الشكر على جهودك في هذا العمل المبارك

مساهمة مني في مشاركة رأي الأستاذ أبو هادي للعمل على تعديل التقويم المستخدم في مشروع العمل أثناء عمل الدوال والرجوع إلى الأصل

فقد وضعت كودًا لذلك سأضع في اقرب وقت إن شاء الله تعالى (نظرًا لأن الكود في الجهاز الخاص بي في المنزل) وأنا أكتب هذا الرد من العمل)

أستاذي الفاضل /

لي بعض ملاحظات أرجو أن تتقبلها مني

تسميتك لبعض الوسائط باسم Date2 وDate1

مع صنعك دالة بنفس الاسم Date2

فلو استبدلت الوسائط بمسميات كالأتي

Date1=> FDate المقصود هنا من تاريخ

Date2=> ToDate والمقصود هنا إلى تاريخ

وتسميتك لوسيطة تنسيق التاريخ في الدالة Format2 بـ Format

ودالة Format من الدوال العامة في النظام ومنعًا للبس لم تم تغييره إلى أي متغيير

مثلاً : DateFormat أو FormatOpt

هذا والله أسأل أن يوفقك لكل خير

أخوك أبوسليمان

[أبوسليمان]

اخي الاستاذ/ أبوسليمان عبدالله سليمان

السلام عليكم ورحمة الله وبركاته وبعد

فهذا استدراك على ردي السابق:

بالنسبة للدالة التي سميت فيها الوسائط بـ Date1 و Date2 هي دالة DateDiff2

وهنا أضع كود تغير التقويم المستخدم في النظام كما ذكرت في ردي السابق

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

ويتضح ذلك من دالة استخراج اسم الشهر "المختصرة"

هذا هو الكود

Option Compare Database
Option Explicit

'CurrCal:  متغير يحتفظ بتقويم النظام
'DoCurrCal:  متغير يبحث هل سبق الاحتفاظ بتقويم النظام

Public CurrCal As Byte, DoCurrCal As Boolean



Public Sub HijriCal()           ' تغيير تقويم النظام إلى الهجري
 SaveCurrCal
 Calendar = vbCalHijri
End Sub



Public Sub GregCal()            ' تغيير تقويم النظام إلى الميلادي
 SaveCurrCal
 Calendar = vbCalGreg
End Sub



Public Sub ReCurrCal()          ' إعادة تقويم النظام
  Calendar = CurrCal
End Sub



Public Sub SaveCurrCal()        ' الاحتفاظ بتقويم النظام
 If (DoCurrCal) Then Exit Sub
    CurrCal = Calendar
    DoCurrCal = True
End Sub

ويتم مناداة الكود للتغيير الى الهجري بالامر :

HijriCal

وللتغيير إلى التقويم الميلادي

GregCal

ولاستعادة تقويم المشروع

ReCurrCal

أرجو أن تكون هذه الأكواد مفيدة ومختصرة للدوال

أخوك

أبوسليمان

تم تعديل سبتمبر 11, 2004 بواسطه أبوسليمان

[أبوسليمان]

أخي العزيز : عبدالله سليمان

بعد النظر في دالة : DateDiff2

وجدت تكرار استدعاء دالة test كما يتضح ذلك في الكود التالي :

dat1 = Test(Date1)                ' الاستدعاء الأول لفحص صحة إدخال التاريخين 
dat2 = Test(Date2)

If dat1 = "" Or dat2 = "" Then Exit Function

If dat1 = dat2 Then
    DateDiff2 = 0
    Exit Function
ElseIf dat1 > dat2 Then
    dat1 = Test(Date1)             ' الاستدعاء الثاني لفحص صحة إدخال التارخين 
    dat2 = Test(Date2)
    salb = -1
End If

فهل الفحص الثاني مقصود أم لا ؟ لأني أجده تكرار للفحص ليس إلا ============= وبعد النظر في الدالة : DateAdd2 وجدت أن وسيطة إضافة ربع سنة ؛ مضروبة في (4) والصحيح أن تضرب في ثلاثة ؛ لأن ربع السنة (3) أشهر وليست أربعة كما يتضح ذلك في الكود التالي:

Case "q"
'       add = add * 4        ' الضرف في أربعة يعني أن ربع السنة يساوي أربعة أشهر 
        add = add * 3        ' والصحيح أن يضرب في ثلاثة لأن ربع السنة ثلاثة أشهر 
        DateAdd2 = DateSerial2(Left(da2, 4), (CLng(Mid(da2, 6, 2))) + add, Right(da2, 2))

أخي العزيز : أرجو ملاحظة ذلك لضمان دقة عمل الدوال إن شاء الله تعالى

أخوك

أبوسليمان

تم تعديل سبتمبر 12, 2004 بواسطه أبوسليمان

[عبدالله سليمان]

تسلم أخوي أبو سليمان على هذه الملاحظات والاقتراحات وزادك الله علماً وتقوى ... وسأحاول قريباً إن شاء الله وضع المثال بعد تعديل الكود ولكن الوقت لايسعفني خلال أيام العمل الرسمية .

[أبو هادي]

السلام عليكم

جزاك الله خيرا أخي أبوسليمان على جهودك .

وهذه بعض الأكواد بما يجب عليها أن تكون بعد اقتراحاتك وتطويع الكود ليكون مستخدما في كل تطبيقات الـ VB و الـ VBA وخصوصا الأكسل بالإصدارات القديمة والحديثة معا .

دالة الاحتفاظ بتقويم النظام بعد إضافة أمر طلب تحميل التقويم .

Public Sub SaveCurrCal()
  If DoCurrCal Then Exit Sub
  
  CurrCal = Calendar
  DoCurrCal = True
  Call LoadUmAlQura_Code
End Sub

دالة الحصول على إسم الشهر تم تعديلها حتى يتمكن مستخدمي النسخ القديمة الإستفادة منها حيث أمر دالة MonthName مستحدثة في الاصدار الأخير فقط .

Public Function MonthName2(da As Byte) As String
  If da < 1 Or da > 12 Then Exit Function
  
  HijriCal
  MonthName2 = Format(DateSerial(Year(Date), da, 1), "mmm")
  ReCurrCal
End Function

بديل لدالة Nz حيث لا توجد في الأكسل وقد يحرمون من الإستفادة من التقويم بسببها .

Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null)
  myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue)
End Function

تحياتي .

[عبدالله سليمان]

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

فعلاً هو كما قلت فعند تحويل تقويم قاعدة البيانات إلى التقويم الهجري لم تعطي دوال أم القرى التحويلية المبرمجة من قبلكم نتائج .

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

وقد جرى تعديل في دالة DateDiff حيث اختصرت كثيراً . وتصحيح الخطأ في حساب ربع السنة .

كما جرى تعديل دوال قبل وبعد التحديث لحقل التاريخ بحيث لاتتوقف عن العمل عندما يكون الحقل في نموذج فرعي

الملفات المرفقة

دوال تاريخ أم القرى.rar ( 69.87ك ) عدد مرات التنزيل: 37

تم تعديل يناير 23, 2005 بواسطه أبو هادي

[أبوسليمان]

أخوي الأستاذ/ عبدالله سليمان

والأستاذ/ أبو هادي

سلام عليكم ورحمة الله وبركاته وبعد

فأشكر لكم بداية تواضعكم وتقبلكم اقتراحاتي ، ومن ثم الاستفادة منها

وهذه كذلك مشاركة بسيطة عبارة عن :

إضافة كودات تغيير وإعادة تقويم النظام إلى دالة Date2

Public Function Date2() As String
Dim da As Date
GregCal
da = Date
    Date2 = Greg2Um(Day(da), Month(da), Year(da))
    Date2 = Format((Year(Date2)), "0000") & "/" & Format((Month(Date2)) _
                                , "00") & "/" & Format((Day(Date2)), "00")
ReCurrCal
End Function

======== اختصار دالة : New2

Public Function Now2()
    Now2 = Date2 & "  " & Time
End Function

==== استحداث دالة أيام الأسبوع : WeekDayName2

Public Function WeekDayName2(da As Byte, Optional fdw As Byte = 1) As String
Dim da1 As Byte
If da < 1 Or da > 7 Then Exit Function
    da1 = da
'    WeekDayName2 = WeekDayName(da1, , fdw)           ' طريقة أولى
    WeekDayName2 = Format(da1 + fdw - 1, "ddd")       ' طريقة ثانية
End Function

======= تنظيم واختصار دالة : Format2

Public Function Format2(expression As String, FormatOpt, Optional FirstDayOfWeek As Byte = 7)
Dim da As Date
Dim da2 As String
Dim day_nu As Integer

    da2 = Test(expression)
If da2 = "" Then Exit Function

Select Case FormatOpt
    Case "yyyy":    Format2 = Year2(da2)
    Case "dd":      Format2 = Day2(da2)
    Case "d":          Format2 = Day2(da2)
    Case "dddd", "ddd", "ddddd"
    Case "dddd", "ddd", "ddddd"
          day_nu = Weekday2(da2, 7)
          Format2 = WeekDayName2(day_nu, 7)  '  باستخدام دالة أيام الأسبوع
    Case "mmm":        Format2 = MonthName2(Month2(da2))
End Select

End Function

=======

أرجو أن تكون مشاركتي هذه ذات فائدة

أخوك

أبوسليمان

[أبو هادي]

السلام عليكم

الأخ أبوسليمان .. أعتقد أن اختصار دوال تبديل التقويم وتخزينه بها ثغرة ، آمل الإطلاع :

Sub AnotherSub()
  GregCal
  '
  '
  ReCurrCal
End Sub

Sub TestSaveCal()
  GregCal
  '
  '
  HijriCal
  '
  '
  Call AnotherSub
  '-- المشكلة تبدأ من هنا
  '-- في هذه المساحة تبدل التقويم من الهجري إلى الميلادي
  '-- والمفترض أن يبقى هجريا
  
  ReCurrCal
End Sub

تحياتي .

[أبو هادي]

السلام عليكم

الأخ عبدالله سليمان .. آمل تجربة تقويم أم القرى في بيئة التقويم الهجري وذلك بعد التعديلات التي وعدت بها :

Option Explicit
  
  Type UmRec
    yy As Integer
    M2(0 To 12) As Integer
    GS As Long
  End Type
  Public UmAll() As UmRec

  Private Type YearData
    M(1 To 12) As Byte
    GS As Date
  End Type
  Private yy As YearData
  
Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null)
  myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue)
End Function

Function HijriYear(ByVal dd As Byte, ByVal mm As Byte, yy As Integer) As Integer
  Dim CurrCal As Byte
  Dim GDate As Date
  
  CurrCal = Calendar
  Calendar = vbCalGreg
  
  GDate = DateSerial(yy, mm, dd)
  Calendar = vbCalHijri
  HijriYear = Year(GDate)
  
  Calendar = CurrCal
End Function

Private Sub FillYear( _
  ByVal GS As String, _
  ByVal M1 As Byte, _
  ByVal M2 As Byte, _
  ByVal M3 As Byte, _
  ByVal M4 As Byte, _
  ByVal M5 As Byte, _
  ByVal M6 As Byte, _
  ByVal M7 As Byte, _
  ByVal M8 As Byte, _
  ByVal M9 As Byte, _
  ByVal M10 As Byte, _
  ByVal M11 As Byte, _
  ByVal M12 As Byte)
                     
  Dim CurrCal As Byte
  
  CurrCal = Calendar
  Calendar = vbCalGreg
  
  yy.GS = DateSerial(Right(GS, 4), Mid(GS, 4, 2), Left(GS, 2))
  yy.M(1) = M1
  yy.M(2) = M2
  yy.M(3) = M3
  yy.M(4) = M4
  yy.M(5) = M5
  yy.M(6) = M6
  yy.M(7) = M7
  yy.M(8) = M8
  yy.M(9) = M9
  yy.M(10) = M10
  yy.M(11) = M11
  yy.M(12) = M12

  Calendar = CurrCal
End Sub

Public Sub LoadYearData(ByVal yy As Integer)
  Select Case yy
    Case 1300: Call FillYear("11-11-1882", 1, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0)
    Case 1301: Call FillYear("31-10-1883", 1, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 1)
    Case 1302: Call FillYear("20-10-1884", 0, 1, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1)
    Case 1303: Call FillYear("09-10-1885", 0, 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0)
    Case 1304: Call FillYear("28-09-1886", 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 0)
    Case 1305: Call FillYear("18-09-1887", 0, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1)
    Case 1306: Call FillYear("07-09-1888", 0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 1, 0)
    Case 1307: Call FillYear("27-08-1889", 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0)
    Case 1308: Call FillYear("16-08-1890", 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 0)
    Case 1309: Call FillYear("05-08-1891", 1, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 0)
    Case 1310: Call FillYear("24-07-1892", 1, 1, 0, 1, 1, 1, 0, 1, 0, 0, 1, 0)
    Case 1311: Call FillYear("14-07-1893", 0, 1, 0, 1, 1, 1, 0, 1, 1, 0, 0, 1)
    Case 1312: Call FillYear("04-07-1894", 0, 0, 1, 0, 1, 1, 0, 1, 1, 1, 0, 0)
    Case 1313: Call FillYear("23-06-1895", 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 0, 1)
    Case 1314: Call FillYear("12-06-1896", 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0, 1)
    Case 1315: Call FillYear("01-06-1897", 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1)
    Case 1316: Call FillYear("21-05-1898", 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 0)
    Case 1317: Call FillYear("10-05-1899", 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 0, 1)
    Case 1318: Call FillYear("30-04-1900", 0, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 0)
    Case 1319: Call FillYear("19-04-1901", 1, 0, 0, 1, 0, 1, 1, 1, 0, 1, 1, 0)
    Case 1320: Call FillYear("09-04-1902", 0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 1, 1)
    Case 1321: Call FillYear("30-03-1903", 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 1)
    Case 1322: Call FillYear("18-03-1904", 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1)
    Case 1323: Call FillYear("07-03-1905", 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1)
    Case 1324: Call FillYear("24-02-1906", 0, 1, 1, 0, 1, 1, 0, 0, 1, 0, 1, 0)
    Case 1325: Call FillYear("13-02-1907", 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1)
    Case 1326: Call FillYear("03-02-1908", 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 1)
    Case 1327: Call FillYear("23-01-1909", 0, 0, 1, 0, 0, 1, 0, 1, 1, 1, 0, 1)
    Case 1328: Call FillYear("12-01-1910", 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 1)
    Case 1329: Call FillYear("01-01-1911", 1, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1)
    Case 1330: Call FillYear("21-12-1911", 1, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0)
    Case 1331: Call FillYear("09-12-1912", 1, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1)
    Case 1332: Call FillYear("29-11-1913", 0, 1, 1, 0, 1, 1, 0, 1, 0, 0, 1, 0)
    Case 1333: Call FillYear("18-11-1914", 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1)
    Case 1334: Call FillYear("08-11-1915", 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0)
    Case 1335: Call FillYear("27-10-1916", 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1)
    Case 1336: Call FillYear("17-10-1917", 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 1)
    Case 1337: Call FillYear("06-10-1918", 0, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1)
    Case 1338: Call FillYear("25-09-1919", 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0)
    Case 1339: Call FillYear("13-09-1920", 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 1)
    Case 1340: Call FillYear("03-09-1921", 0, 0, 1, 1, 0, 1, 1, 1, 0, 1, 0, 0)
    Case 1341: Call FillYear("23-08-1922", 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0)
    Case 1342: Call FillYear("13-08-1923", 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0)
    Case 1343: Call FillYear("01-08-1924", 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0)
    Case 1344: Call FillYear("21-07-1925", 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0)
    Case 1345: Call FillYear("10-07-1926", 1, 1, 0, 1, 1, 0, 1, 0, 1, 0, 0, 1)
    Case 1346: Call FillYear("30-06-1927", 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0)
    Case 1347: Call FillYear("18-06-1928", 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0)
    Case 1348: Call FillYear("08-06-1929", 0, 1, 0, 0, 1, 1, 0, 1, 1, 1, 0, 1)
    Case 1349: Call FillYear("29-05-1930", 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, 1, 0)
    Case 1350: Call FillYear("18-05-1931", 1, 0, 0, 1, 0, 0, 1, 0, 1, 1, 1, 0)
    Case 1351: Call FillYear("06-05-1932", 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 1, 0)
    Case 1352: Call FillYear("25-04-1933", 1, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0)
    Case 1353: Call FillYear("14-04-1934", 1, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 0)
    Case 1354: Call FillYear("04-04-1935", 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1)
    Case 1355: Call FillYear("24-03-1936", 0, 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0)
    Case 1356: Call FillYear("13-03-1937", 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1, 1)
    Case 1357: Call FillYear("03-03-1938", 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1)
    Case 1358: Call FillYear("20-02-1939", 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 1)
    Case 1359: Call FillYear("09-02-1940", 1, 0, 1, 1, 0, 0, 1, 0, 0, 1, 0, 1)
    Case 1360: Call FillYear("28-01-1941", 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0)
    Case 1361: Call FillYear("17-01-1942", 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 0)
    Case 1362: Call FillYear("07-01-1943", 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1)
    Case 1363: Call FillYear("28-12-1943", 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0, 1)
    Case 1364: Call FillYear("16-12-1944", 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1)
    Case 1365: Call FillYear("05-12-1945", 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1)
    Case 1366: Call FillYear("24-11-1946", 1, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0)
    Case 1367: Call FillYear("13-11-1947", 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 1)
    Case 1368: Call FillYear("02-11-1948", 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 0, 0)
    Case 1369: Call FillYear("22-10-1949", 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0)
    Case 1370: Call FillYear("12-10-1950", 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 1)
    Case 1371: Call FillYear("02-10-1951", 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1)
    Case 1372: Call FillYear("20-09-1952", 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1)
    Case 1373: Call FillYear("09-09-1953", 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1)
    Case 1374: Call FillYear("29-08-1954", 1, 0, 1, 1, 1, 0, 1, 0, 0, 1, 0, 0)
    Case 1375: Call FillYear("18-08-1955", 1, 0, 1, 1, 1, 0, 1, 1, 0, 0, 1, 0)
    Case 1376: Call FillYear("07-08-1956", 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1)
    Case 1377: Call FillYear("28-07-1957", 0, 0, 1, 0, 1, 0, 1, 1, 1, 0, 1, 0)
    Case 1378: Call FillYear("17-07-1958", 1, 0, 0, 1, 0, 1, 0, 1, 1, 0, 1, 1)
    Case 1379: Call FillYear("07-07-1959", 0, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1, 1)
    Case 1380: Call FillYear("25-06-1960", 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1)
    Case 1381: Call FillYear("14-06-1961", 0, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 0)
    Case 1382: Call FillYear("03-06-1962", 0, 1, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1)
    Case 1383: Call FillYear("24-05-1963", 0, 0, 1, 0, 1, 1, 1, 0, 1, 1, 0, 0)
    Case 1384: Call FillYear("12-05-1964", 1, 0, 0, 1, 0, 1, 1, 0, 1, 1, 1, 0)
    Case 1385: Call FillYear("02-05-1965", 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 0)
    Case 1386: Call FillYear("21-04-1966", 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0)
    Case 1387: Call FillYear("10-04-1967", 1, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 0)
    Case 1388: Call FillYear("29-03-1968", 1, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1)
    Case 1389: Call FillYear("19-03-1969", 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 0)
    Case 1390: Call FillYear("08-03-1970", 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1)
    Case 1391: Call FillYear("26-02-1971", 0, 1, 0, 0, 1, 0, 1, 1, 1, 0, 1, 1)
    Case 1392: Call FillYear("16-02-1972", 0, 0, 1, 0, 0, 1, 0, 1, 1, 0, 1, 1)
    Case 1393: Call FillYear("04-02-1973", 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1)
    Case 1394: Call FillYear("24-01-1974", 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1)
    Case 1395: Call FillYear("13-01-1975", 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 0)
    Case 1396: Call FillYear("02-01-1976", 1, 0, 1, 1, 1, 0, 1, 0, 0, 1, 0, 1)
    Case 1397: Call FillYear("22-12-1976", 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 0)
    Case 1398: Call FillYear("11-12-1977", 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 1)
    Case 1399: Call FillYear("01-12-1978", 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0)
    Case 1400: Call FillYear("20-11-1979", 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 1, 0)
    Case 1401: Call FillYear("08-11-1980", 1, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0)
    Case 1402: Call FillYear("28-10-1981", 1, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1)
    Case 1403: Call FillYear("18-10-1982", 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0)
    Case 1404: Call FillYear("07-10-1983", 0, 1, 1, 0, 1, 1, 1, 0, 1, 0, 0, 1)
    Case 1405: Call FillYear("26-09-1984", 0, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 0)
    Case 1406: Call FillYear("15-09-1985", 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1)
    Case 1407: Call FillYear("05-09-1986", 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1)
    Case 1408: Call FillYear("25-08-1987", 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1)
    Case 1409: Call FillYear("13-08-1988", 1, 0, 1, 1, 0, 1, 0, 1, 0, 0, 1, 0)
    Case 1410: Call FillYear("02-08-1989", 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 1)
    Case 1411: Call FillYear("23-07-1990", 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 0)
    Case 1412: Call FillYear("12-07-1991", 1, 0, 0, 1, 1, 0, 1, 1, 1, 0, 1, 0)
    Case 1413: Call FillYear("01-07-1992", 0, 1, 0, 0, 1, 1, 0, 1, 1, 0, 1, 1)
    Case 1414: Call FillYear("21-06-1993", 0, 0, 1, 0, 0, 1, 0, 1, 1, 1, 0, 1)
    Case 1415: Call FillYear("10-06-1994", 0, 1, 0, 1, 0, 0, 1, 0, 1, 1, 0, 1)
    Case 1416: Call FillYear("30-05-1995", 1, 0, 1, 0, 1, 0, 1, 0, 0, 1, 0, 1)
    Case 1417: Call FillYear("18-05-1996", 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 0)
    Case 1418: Call FillYear("07-05-1997", 1, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0)
    Case 1419: Call FillYear("27-04-1998", 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1)
    Case 1420: Call FillYear("17-04-1999", 0, 1, 0, 0, 1, 0, 1, 1, 1, 1, 0, 1)
    Case 1421: Call FillYear("06-04-2000", 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 1)
    Case 1422: Call FillYear("26-03-2001", 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 0, 1)
    Case 1423: Call FillYear("15-03-2002", 1, 0, 1, 0, 1, 0, 0, 1, 0, 1, 0, 1)
    Case 1424: Call FillYear("04-03-2003", 1, 0, 1, 1, 0, 1, 0, 0, 1, 0, 1, 0)
    Case 1425: Call FillYear("21-02-2004", 1, 0, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0)
    Case 1426: Call FillYear("10-02-2005", 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1)
    Case 1427: Call FillYear("31-01-2006", 0, 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0)
    Case 1428: Call FillYear("20-01-2007", 1, 0, 0, 1, 0, 0, 1, 1, 1, 0, 1, 1)
    Case 1429: Call FillYear("10-01-2008", 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1)
    Case 1430: Call FillYear("29-12-2008", 0, 1, 1, 0, 0, 1, 0, 1, 0, 1, 0, 1)
    Case 1431: Call FillYear("18-12-2009", 0, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1)
    Case 1432: Call FillYear("07-12-2010", 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0)
    Case 1433: Call FillYear("26-11-2011", 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 0)
    Case 1434: Call FillYear("15-11-2012", 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0)
    Case 1435: Call FillYear("04-11-2013", 1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1)
    Case 1436: Call FillYear("25-10-2014", 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1)
    Case 1437: Call FillYear("14-10-2015", 1, 0, 1, 1, 0, 0, 1, 0, 1, 0, 0, 1)
    Case 1438: Call FillYear("02-10-2016", 1, 0, 1, 1, 1, 0, 0, 1, 0, 0, 1, 0)
    Case 1439: Call FillYear("21-09-2017", 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0, 1)
    Case 1440: Call FillYear("11-09-2018", 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 0)
    Case 1441: Call FillYear("31-08-2019", 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0)
    Case 1442: Call FillYear("20-08-2020", 0, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0)
    Case 1443: Call FillYear("09-08-2021", 1, 0, 1, 0, 1, 0, 1, 0, 1, 0, 1, 1)
    Case 1444: Call FillYear("30-07-2022", 0, 1, 0, 1, 1, 0, 0, 1, 0, 1, 0, 1)
    Case 1445: Call FillYear("19-07-2023", 0, 1, 1, 1, 0, 1, 0, 0, 1, 0, 0, 1)
    Case 1446: Call FillYear("07-07-2024", 0, 1, 1, 1, 0, 1, 1, 0, 0, 1, 0, 0)
    Case 1447: Call FillYear("26-06-2025", 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0)
    Case 1448: Call FillYear("16-06-2026", 0, 1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1)
    Case 1449: Call FillYear("06-06-2027", 0, 0, 1, 0, 1, 0, 1, 1, 0, 1, 1, 0)
    Case 1450: Call FillYear("25-05-2028", 1, 0, 1, 0, 0, 1, 0, 1, 0, 1, 1, 0)
  End Select
End Sub

Sub LoadUmAlQura_Code()
  Const hmd = 29
  Dim mm As Byte
  Dim HY As Long
  Dim Days As Long
  Dim FRec As Long
  Dim LRec As Long
  Dim Test As Variant
  
  On Error Resume Next
  
  Test = LBound(UmAll)
  If Err.number = 0 Then Exit Sub
  
  FRec = 1300
  LRec = 1450
  ReDim Preserve UmAll(FRec To LRec) As UmRec
  For HY = FRec To LRec
    Call LoadYearData(HY)
    UmAll(HY).yy = HY
    UmAll(HY).GS = yy.GS
    Days = 0
    For mm = 1 To 12
      Days = Days + yy.M(mm) + hmd
      UmAll(HY).M2(mm) = Days
    Next mm
  Next HY
End Sub

Function Greg2Um(ByVal dd As Byte, ByVal mm As Byte, ByVal yy As Integer) As Variant
  Dim K As Byte
  Dim HD2 As Integer
  Dim HM2 As Integer
  Dim HY2 As Integer
  Dim MDays As Integer
  Dim InDays As Long
  Dim Days As Variant
  Dim Hijri As String
  Dim Test As Variant
  Dim CurrCal As Byte
  
  On Error Resume Next
  
  CurrCal = Calendar
  Calendar = vbCalGreg
  
  Call LoadUmAlQura_Code
  Greg2Um = Null
  If Not IsDate(DateSerial(yy, mm, dd)) Then GoTo ExitFunction
  
  Days = DateSerial(yy, mm, dd)
  InDays = Days
  
  yy = HijriYear(dd, mm, yy)
  If yy > UBound(UmAll) And _
     Days <= UmAll(UBound(UmAll)).GS + UmAll(UBound(UmAll)).M2(12) Then
    yy = yy - 1
  End If
  
  Days = Null
  Days = CLng(UmAll(yy).GS)
  If IsNull(Days) Then GoTo ExitFunction
  
  If (InDays < Days) Or (InDays > (Days + UmAll(yy).M2(12) - 1)) Then
    If InDays < Days Then yy = yy - 1 Else yy = yy + 1
  End If
  
  If yy >= LBound(UmAll) Or yy <= UBound(UmAll) Then
    Days = UmAll(yy).GS
    If IsNull(Days) Then GoTo ExitFunction
    
    Days = InDays - Days + 1
    For K = 0 To 11
      If UmAll(yy).M2(K + 1) > Days - 1 Then Exit For
    Next K
    
    dd = Days - UmAll(yy).M2(K)
    mm = K + 1
    Greg2Um = Format(dd, "00") & "/" & Format(mm, "00") & "/" & Format(yy, "0000")
  End If

ExitFunction:
  Calendar = CurrCal
End Function

Function Um2Greg(ByVal dd As Byte, ByVal mm As Byte, ByVal yy As Integer) As Variant
  Dim Days As Variant
  
  On Error Resume Next
  
  Call LoadUmAlQura_Code
  Um2Greg = Null
  Days = Null
  Days = UmAll(yy).GS
  If IsNull(Days) Then Exit Function
  
  Um2Greg = Days + UmAll(yy).M2(mm - 1) + dd - 1
End Function

Function IsUmAlQura(ByVal dd As Byte, ByVal mm As Byte, ByVal yy As Integer) As Boolean
  Dim Greg  As Variant
  Dim Hijri As Variant
  Dim d As Byte
  Dim M As Byte
  Dim Y As Integer
  Dim CurrCal As Byte
    
  CurrCal = Calendar
  Calendar = vbCalGreg
  
  Call LoadUmAlQura_Code
  Greg = CDate(myNz(Um2Greg(dd, mm, yy)))
  If IsDate(Greg) Then
    d = Day(Greg)
    M = Month(Greg)
    Y = Year(Greg)
  End If
  
  Hijri = Greg2Um(d, M, Y)
  If Not IsNull(Hijri) Then
    d = Val(Left(Hijri, 2))
    M = Val(Mid(Hijri, 4, 2))
    Y = Val(Right(Hijri, 4))
  End If
  
  IsUmAlQura = (d = dd) And (M = mm) And (Y = yy)
  
  Calendar = CurrCal
End Function

Function UmMonthDays(ByVal mm As Byte, ByVal yy As Integer) As Byte
  Do While mm < 1:  mm = mm + 12: yy = yy - 1: Loop
  Do While mm > 12: mm = mm - 12: yy = yy + 1: Loop

  Call LoadUmAlQura_Code
  If yy < LBound(UmAll) Or yy > UBound(UmAll) Then Exit Function
  
  UmMonthDays = UmAll(yy).M2(mm) - UmAll(yy).M2(mm - 1)
End Function

Function Hijri2Text(Hijri As String, Lang As Byte) As String
  Const vArabic = 1
  Const vEnglish = 2
  Dim Pos As Byte
  Dim dd As String
  Dim mm As String
  Dim yy As String
  
  Pos = InStr(1, Hijri, "/")
  
  Select Case Pos
    Case 3
      dd = Left(Hijri, 2)
      mm = Mid(Hijri, 4, 2)
      yy = Mid(Hijri, 7, 4)
    Case 5
      dd = Mid(Hijri, 9, 2)
      mm = Mid(Hijri, 6, 2)
      yy = Left(Hijri, 4)
    Case Else
      Hijri2Text = ""
      Exit Function
  End Select
  
  Select Case Lang
    Case vArabic
      Hijri2Text = yy & mm & dd
    Case vEnglish
      Hijri2Text = dd & mm & yy
  End Select
End Function

Function Hijri_Arabic(ByVal inHijri As String) As String
  Dim Hijri As String
  
  Hijri = Hijri2Text(inHijri, 1)
  Hijri_Arabic = Left(Hijri, 4) & "/" & Mid(Hijri, 5, 2) & "/" & Right(Hijri, 2)
End Function

تحياتي .

[أبوسليمان]

صدقت أخي أبو هادي

حقيقة لم تخطر على بالي هذه الثغرة

والبحث جارٍ للوصول إلى سد هذه الثغرة

ولن نحرم من حلولك في سد هذه الثغرة ومثلك لن يعجز بإذن الله

أخوك

أبوسليمان

[عبدالله سليمان]

الأخ / أبو سليمان

سأراجع الكود مرة أخرى حسب أقتراحاتكم الأخيرة ، وشيء طيب أن نصل إلى مرحلة التحسينات . فشكراً لك .

الأخ / أبو هادي

سأجرب التقويم بعد التعديل ووأفيك وبقية القراء بالنتيجة قريباً إن شاء الله . وشكراً لك على اهتمامك بهذا التقويم .

أخيراً أود أن أوضح أن الدوال التحويلية والدوال التاريخية لتقويم أم القرى مهم جداً لكل من يريد برمجة قاعدة بيانات وهو مقيم في السعودية بسبب اعتماد هذا التقويم في المعاملات الرسمية وغير الرسمية .

وقد أصبحت سهلة الاستخدام ، وسأطرح شرح بسيط لعملها قريباً إن شاء الله .

تم تعديل سبتمبر 19, 2004 بواسطه عبدالله سليمان

[أبوسليمان]

أخي الأستاذ/ عبدالله سليمان

قواك الله وعطاك ألف عافية

نحن في انتظارك

أخي الأستاذ/ أبو هادي

أذكر أنك وضعت تقويمًا حتى سنة 1500هـ

وذلك في منتديات الفريق العربي للبرمجة ، وقد تلفت روابط أمثلتها

وأرى التعامل هنا بالكود يقتصر حتى سنة 1450هـ

فهل هناك ما يمنع من إضافة ال (50) سنة الباقية في الكود

أرجو الإفادة

وجزاك الله ألف خير

أخوك

أبوسليمان

[أبو هادي]

السلام عليكم

أخي أبوسليمان حفظك الله

الـ 50 سنة تلك هي من نتائج تقويمي الفلكي وليست من نتائج مدينة الملك عبدالعزيز للعلوم والتكنولوجيا . وكما أذكر أني أوضحت أن صحة البيانات تتجاوز الـ 99% ، ولكن لم أحصل على تأييد باستخدامها ولا أدري الآن أين أحتفظ بهذه النتائج ، ولكن إن رأيتم أن أبحث عنها بحثت ، وإلا فأني أرفق لكم برنامج احتساب الشهور الفلكية حسب مدينة أم القرى بلغة باسكال .

تحياتي .

الملفات المرفقة

MOON2.rar ( 34.34ك ) عدد مرات التنزيل: 19

تم تعديل يناير 23, 2005 بواسطه أبو هادي