Option Base 0

Public Const SHBaseYear = 1278
Public Const SHBaseMonth = 12
Public Const SHBaseDay = 29
Function SHIsLeap_Year(ByVal ShYear As Long) As Boolean
Dim LEAP1 As Single
   SHIsLeap_Year = False
   LEAP1 = (8 * ShYear + 22) / 33 - 0.001
   LEAP1 = LEAP1 - Int(LEAP1)
   If (LEAP1 > 0.77) Or (LEAP1 = 0) Then SHIsLeap_Year = True
End Function

Function SHLeap_Count(ByVal ShYear As Long) As Integer
Dim LEAP1 As Integer, LEAP2 As Integer, LEAP3 As Integer
   LEAP1 = (ShYear - 22) \ 33
   LEAP2 = ((ShYear - 22) Mod 33) \ 4
   If ShYear >= 22 Then
      LEAP3 = 6 + (8 * LEAP1) + LEAP2 '6=(22 \ 4) + 1) leap days til Shyear=22
   Else
      LEAP3 = (ShYear + 3) \ 4 'the first leap year  as  Shyear=1
   End If
   If (ShYear - 21) Mod 33 = 0 Then LEAP3 = LEAP3 - 1
   SHLeap_Count = LEAP3
End Function



Sub CH_To_SH(ByVal CHDate As Date, Year As Long, Month As Long, Day As Long)
Dim DayNum As Long, ReminderDay As Long
Dim NewYear As Long, NewMonth As Long, NewDay As Long

NewYear = 0
NewMonth = 0
NewDay = 0

   DayNum = Round(CHDate) - 80
   NewYear = (DayNum \ 365) + SHBaseYear + 1
   ReminderDay = (DayNum Mod 365) - (SHLeap_Count(NewYear - 1) - SHLeap_Count(SHBaseYear))

   If ReminderDay <= 0 Then
      NewYear = NewYear - 1
      ReminderDay = 365 + (DayNum Mod 365)
      ReminderDay = ReminderDay - (SHLeap_Count(NewYear - 1) - SHLeap_Count(SHBaseYear))
   End If

   If ReminderDay <= 0 Then
     NewYear = NewYear - 1
     If SHIsLeap_Year(NewYear) Then
        ReminderDay = 366
     Else
        ReminderDay = 365
     End If
   End If

   NewMonth = ((ReminderDay - 1) \ 31) + 1
   NewDay = ReminderDay Mod 31
   If NewDay = 0 Then NewDay = 31
   If NewMonth > 6 Then
      NewDay = NewDay + (NewMonth - 7)
      NewMonth = NewMonth + ((NewDay - 1) \ 30)
      NewDay = (NewDay Mod 30)
      If NewDay = 0 Then NewDay = 30
   End If
   Year = NewYear
   Month = NewMonth
   Day = NewDay
End Sub

Function FDate(ADate As String, Zero As Boolean, Optional Four As Boolean = False) As String
Dim Y As Long, M As Long, D As Long
Dim ys As String, ms As String, ds As String
    CH_To_SH CDate(ADate), Y, M, D
    If Four Then
       ys = Str(Y)
    Else
       ys = Right$(Str(Y), 2)
    End If
    If Zero Then
      If Len(Trim(Str(M))) < 2 Then
         ms = "0" + Trim(Str(M))
      Else
         ms = Trim(Str(M))
      End If
      If Len(Trim(Str(D))) < 2 Then
         ds = "0" + Trim(Str(D))
      Else
         ds = Trim(Str(D))
      End If
    Else
         ms = Trim(Str(M))
         ds = Trim(Str(D))
    End If
    FDate = ys & "/" & ms & "/" & ds
End Function