Need Correction in Custom Function

[loverfellow]

Hi everyone,

I have found this custom function which converts Hijri date into Georgian date. It converts hijri date from "month/day/year" (eg. 2/20/1437) format to Georgian date successfully but if i try it on on any hijri date from "day/month/year" (eg.20/2/1437) it does not work. I have tried edit but I can't make it work. Please look into below code and suggest any changes to get the desired result.

Option Base 1


Function isleap(n) As Boolean
  isleap = ((n Mod 4 = 0) And (n Mod 400 <> 0))
End Function


Function isLeapH(n) As Boolean
  isLeapH = (n = 3 Or n = 5 Or n = 8)
End Function


Function FindYear(n)
  'Returns number of whole years elapsed in current cycle
  YearFinder = Array(354, 708, 1063, 1417, 1772, 2126, 2480, 2835)
  For i = 1 To 8
    If n <= YearFinder(i) Then
      FindYear = i
      Exit For
    End If
  Next i
End Function


Function FindMonth(n, leap)
  'Returns number of whole months elapsed in current year
  MonthFinderL = Array(30, 59, 89, 118, 148, 177, 207, 236, 266, 296, 325, 355)
  MonthFinder = Array(29, 59, 88, 118, 147, 177, 206, 236, 265, 295, 324, 354)
  'would't let me make these two public!
  If leap Then
    For i = 1 To 12
      If n <= MonthFinderL(i) Then
        FindMonth = i
        Exit For
      End If
    Next i
  Else
    For i = 1 To 12
      If n <= MonthFinder(i) Then
        FindMonth = i
        Exit For
      End If
    Next i
  End If
End Function


Function H(dat As Long) As String
  Hstart = 1324
  Cstart = CLng(#2/24/1906#)            'Corresponds to 1 Muharram 1324
  DCycle = 2835
  YearFinder = Array(354, 708, 1063, 1417, 1772, 2126, 2480, 2835)
  MonthFinderL = Array(30, 59, 89, 118, 148, 177, 207, 236, 266, 296, 325, 355)
  MonthFinder = Array(29, 59, 88, 118, 147, 177, 206, 236, 265, 295, 324, 354)
  elp = dat - Cstart
  ncycles = elp \ DCycle         'Number of elapsed cycles
  ndays_thiscycle = elp Mod DCycle
  If ndays_thiscycle = 0 Then     'Last day of the cycle
    hyr = Hstart + ncycles * 8
    H = "12/30/" & hyr
    Exit Function
  End If
  nyear = FindYear(ndays_thiscycle)   'This year in current cycle
  leapH = isLeapH(nyear)
  If nyear = 1 Then
    ndays_thisyear = ndays_thiscycle
  Else
    ndays_thisyear = ndays_thiscycle - YearFinder(nyear - 1)
  End If
  months = FindMonth(ndays_thisyear, leapH)   'This month in current year
  If months = 1 Then
    daysinmonths = 0                  'Days in preceding months
  ElseIf leapH Then
    daysinmonths = MonthFinderL(months - 1)
  Else
    daysinmonths = MonthFinder(months - 1)
  End If
  ndays = ndays_thisyear - daysinmonths + 1
  hyr = Hstart + ncycles * 8 + nyear - 1
  Debug.Print dat, ncycles, ndays_thiscycle
  Debug.Print nyear, leapH
  Debug.Print ndays_thisyear, months, daysinmonths
  H = months & "/" & ndays & "/" & hyr
End Function


Sub convert_month()
  Dim a(31)
  last_day = Array(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
  s = InputBox("enter month and year in the form mm/yyyy:")
  y = CInt(Right(s, 4))
  m = CInt(Left(s, 2))
  d = DateSerial(y, m, 1)
  L = last_day(m)
  For i = 1 To L
    a(i) = H(d + i - 1)
    Debug.Print i, a(i)
  Next i
End Sub


Function G(hdat As String) As Date
  YearFinder = Array(354, 708, 1063, 1417, 1772, 2126, 2480, 2835)
  MonthFinderL = Array(30, 59, 89, 118, 148, 177, 207, 236, 266, 296, 325, 355)
  MonthFinder = Array(29, 59, 88, 118, 147, 177, 206, 236, 265, 295, 324, 354)
  Cstart = CLng(#2/24/1906#)            'Corresponds to 1 Muharram 1324
  Hstart = 1324
  DCycle = 2835
  'parse s to produce hmonth, hday, hyear
  i = InStr(hdat, "/")
  hmonth = CInt(Left(hdat, i - 1))
  j = InStr(i + 1, hdat, "/")
  hday = CInt(Mid(hdat, i + 1, j - i - 1))
  hyear = CInt(Right(hdat, Len(hdat) - j))
  elapsed_years = hyear - Hstart
  ncycles = elapsed_years \ 8
  nyear = elapsed_years Mod 8
  If nyear = 0 Then
    days_thiscycle = 0
  Else
    days_thiscycle = YearFinder(nyear)
  End If
  leap = isLeapH(nyear)
  If hmonth = 1 Then
    days_thisyear = hday
  Else
    If leap Then
      days_thisyear = MonthFinderL(hmonth - 1) + hday
    Else
      days_thisyear = MonthFinder(hmonth - 1) + hday
    End If
  End If
  days_thiscycle = days_thiscycle + days_thisyear
  G = Cstart - 1 + ncycles * DCycle + days_thiscycle
End Function

 

[RickXL]

Hi,

Do these work for you?

Function G2H(dtGregDate As Date) As String
    ' returns a date in Hijri format for a given western date
    VBA.Calendar = vbCalHijri
    G2H = dtGregDate
    VBA.Calendar = vbCalGreg
End Function

Function H2G(dtHijDate As String) As Date
    ' returns a Gregorian date in from a string containing a Hijri date
    VBA.Calendar = vbCalHijri
    H2G = dtHijDate
    VBA.Calendar = vbCalGreg
End Function

Sub Test_Hijri_Gregorian_Conversion()
    MsgBox H2G("19/12/1437") & vbLf & G2H("21/09/2016")
End Sub

They use the built-in Hijri functionality and swap the calendar locales to perform the conversions.
The last macro is just a demonstration of how they work.