Hijri to Gregorian Converter (1 Viewer)

[Kha]

Hi,
I made a conversion tool from Hijri to Gregorian, but the process did not work for me, please help me to build it correctly
When I put in the date I get the same date without converting to the Gregorian date

Public Function GetGreg(Greg As Date)
Greg = CDate(Greg)
VBA.Calendar = vbCalGreg
GetGreg = Format(Greg, "dd/mm/yyyy")
GetGreg = CStr(GetGreg)
End Function

Sample in the attachement

 

[Kha]

 

[The_Doc_Man]

Use this forum's SEARCH function (upper menu bar, right end) to search for "Hijri calendar" and see if any of the resulting articles help you any. I don't know anything about Hijri calendars but apparently the question has come up more than once, because there are over a dozen hits within the forum. You can also search the web for this. Using the search text "VBA Hijri Calendar" I found quite a few hits. Here is one that might help.

Redirecting

As to why you get the same input and output, I don't see that you are doing anything that would change your calendar from one form to another.

 

[arnelgp]

i converted a function from Javascript.
maybe you can find use in them.

' converted to VBA from jscript from
' https://www.vbforums.com/showthread.php?844053-RESOLVED-VBA-Mystery-Convert-Gregorian-date-to-Hijri-date-and-vice-versa
' by arnelgp
'
Public Sub GrogorianToHijri(ByVal arg As Date, ByRef ret_day As Integer, ByRef ret_month As Integer, ByRef ret_year As Integer)

    Dim d As Integer, m As Integer, y As Integer
    Dim l As Long, n As Long, j As Long
    Dim jd As Long
    d = Day(arg)
    m = Month(arg)
    y = Year(arg)
    If ((y > 1582) Or ((y = 1582) And (m > 10)) Or ((y = 1582) And (m = 10) And (d > 14))) Then
        jd = Int((1461 * (y + 4800 + Int((m - 14) / 12))) / 4) + Int((367 * (m - 2 - 12 * (Int((m - 14) / 12)))) / 12) - Int((3 * (Int((y + 4900 + Int((m - 14) / 12)) / 100))) / 4) + d - 32075
    Else
        jd = 367 * y - Int((7 * (y + 5001 + Int((m - 9) / 7))) / 4) + Int((275 * m) / 9) + d + 1729777
    End If

    'arg.jd.Value = jd
    'arg.wd.value=weekDay(jd%7)
    l = jd - 1948440 + 10632
    n = Int((l - 1) / 10631)
    l = l - 10631 * n + 354
    j = (Int((10985 - l) / 5316)) * (Int((50 * l) / 17719)) + (Int(l / 5670)) * (Int((43 * l) / 15238))
    l = l - (Int((30 - j) / 15)) * (Int((17719 * j) / 50)) - (Int(j / 16)) * (Int((15238 * j) / 43)) + 29
    m = Int((24 * l) / 709)
    d = l - Int((709 * m) / 24)
    y = 30 * n + j - 30

    ret_day = d
    ret_month = m
    ret_year = y
End Sub


Public Sub HijriToGregorian(ByVal arg As Date, ByRef ret_day As Integer, ByRef ret_month As Integer, ByRef ret_year As Integer)
    Dim d As Integer, m As Integer, y As Integer
    Dim l As Long, n As Long, j As Long, k As Long, i As Long
    Dim jd As Long, dt As Date
    
'    dt = CDate(arg)
'
'    d = Day(dt)
'    m = Month(dt)
'    y = Year(dt)
    d = Day(arg)
    m = Month(arg)
    y = Year(arg)
    
    jd = Int((11 * y + 3) \ 30) + (CLng(354) * CLng(y)) + (30 * m) - Int((m - 1) \ 2) + d + CLng(1948440) - 385
    
    If (jd > 2299160) Then
        l = jd + 68569
        n = Int((4 * l) / 146097)
        l = l - Int((146097 * n + 3) / 4)
        i = Int((4000 * (l + 1)) / 1461001)
        l = l - Int((1461 * i) / 4) + 31
        j = Int((80 * l) / 2447)
        d = l - Int((2447 * j) / 80)
        l = Int(j / 11)
        m = j + 2 - 12 * l
        y = 100 * (n - 49) + i + l
    Else
        j = jd + 1402
        k = Int((j - 1) / 1461)
        l = j - 1461 * k
        n = Int((l - 1) / 365) - Int(l / 1461)
        i = l - 365 * n + 30
        j = Int((80 * i) / 2447)
        d = i - Int((2447 * j) / 80)
        i = Int(j / 11)
        m = j + 2 - 12 * i
        y = 4 * k + n + i - 4716
    End If
    ret_day = d
    ret_month = m
    ret_year = y

End Sub


Private Sub test()
Dim dt As Date
Dim d As Integer, m As Integer, y As Integer
dt = Date

Debug.Print Day(dt), Month(dt), Year(dt)

GrogorianToHijri dt, d, m, y
Debug.Print d, m, y

HijriToGregorian DateSerial(y, m, d), d, m, y
Debug.Print d, m, y

End Sub

 

[arnelgp]

but this is somewhat accurate:

' http://www.islamicsoftware.org/hijridates/hijri.bas
'
Option Base 1

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

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

Function FindYear(ByVal n As Long)
  Dim YearFinder, i As Integer
  '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(ByVal n As Integer, ByVal leap As Boolean)
  Dim MonthFinderL, MonthFinder, i As Integer
  '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 HijriDate(dat As Long) As String
  Dim Hstart As Long, Cstart As Long, DCycle As Integer, YearFinder, MonthFinderL, MonthFinder
  Dim elp As Long, ncycles As Long, ndays_thiscycle As Long, hyr As Long
  Dim nyear As Long, leapH As Boolean, ndays_thisyear As Long
  Dim months As Integer, ndays As Integer, daysinmonths As Integer
  Dim ret As String, ret_date As Date
  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
    HijriDate = "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
  hyr = Hstart + ncycles * 8 + nyear - 1
  'Debug.Print dat, ncycles, ndays_thiscycle
  'Debug.Print nyear, leapH
  'Debug.Print ndays_thisyear, months, daysinmonths
  ret = months & "/" & ndays & "/" & hyr
 
  'arnelgp
  'adjust the value if it is less
  ret_date = GregDate(ret)
  If ret_date < dat Then
     ndays = ndays + 1
  ElseIf ret_date > dat Then
     ndays = ndays - 1
  End If
  ret = months & "/" & ndays & "/" & hyr
  HijriDate = ret
End Function

Sub convert_month()
  Dim a(31), last_day, s As String, y As Integer, m As Integer, d As Date, l As Integer, i As Integer
  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) = HijriDate(d + i - 1)
    Debug.Print i, a(i)
  Next i
End Sub

Function GregDate(hdat As String) As Date
  Dim YearFinder, MonthFinderL, MonthFinder, Cstart As Long, Hstart As Integer, DCycle As Integer
  Dim i As Integer, hmonth As Integer, j As Integer, hday As Integer, hyear As Integer
  Dim elapsed_years As Integer, ncycles As Integer, nyear As Integer
  Dim days_thiscycle As Integer, leap As Boolean, days_thisyear As Integer
 
  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
  GregDate = Cstart - 1 + CLng(ncycles) * CLng(DCycle) + days_thiscycle
End Function



Private Sub test()
Dim s As String
s = HijriDate(#5/1/2022#)
Debug.Print
Debug.Print s
Debug.Print GregDate(s)

End Sub

 

[ebs17]

Public Function HijriToGregorian(AnyDate As Date) As Date
    Dim lDate As Long
    'VBA.Calendar = vbCalHijri
    lDate = CLng(AnyDate)
    'Debug.Print lDate
    VBA.Calendar = vbCalGreg
    HijriToGregorian = CDate(lDate)
End Function

Sub call_HijriToGregorian()
    Dim dtHijri As Date
    Dim dtGregorian As Date
    VBA.Calendar = vbCalHijri
    Debug.Print CDate("01.01.1444"), DateSerial(1444, 1, 1)
 
    dtHijri = CDate("01.01.1444")
    dtGregorian = HijriToGregorian(dtHijri)
    Debug.Print dtGregorian
End Sub

 

[Kha]

Thnaks for codes,
I tried it, but the code does not convert it to the Gregorian date
DB Attached

 

[Nixversteher]

the code from ebs works, only you have to adjust the function

Public Function HijriToGregorian(AnyDate As String) As Date
    Dim lDate As Date
    VBA.Calendar = vbCalHijri
    lDate = CDate(AnyDate)
    VBA.Calendar = vbCalGreg
    HijriToGregorian = lDate
End Function

 

[arnelgp]

i used code in post #4.
test it.