Attribute VB_Name = "modDateTime"
'-----------------------------------------------------
' MirageBot Time Manipulation Module
' Written by Christopher Nevin (lancergli@gmail.com)
'-----------------------------------------------------

Option Explicit
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Function lstrlenW Lib "kernel32" (lpString As Any) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function GetDateFormat Lib "kernel32" Alias "GetDateFormatA" (ByVal Locale As Long, ByVal dwFlags As Long, lpDate As SYSTEMTIME, ByVal lpFormat As String, ByVal lpDateStr As String, ByVal cchDate As Long) As Long
Public Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Boolean
Public Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long

Private Const TIME_ZONE_ID_INVALID           As Long = &HFFFFFFFF
Private Const TIME_ZONE_ID_UNKNOWN           As Long = &H0
Private Const TIME_ZONE_ID_STANDARD          As Long = &H1
Private Const TIME_ZONE_ID_DAYLIGHT          As Long = &H2
Private Const ACP As Long = 0

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Public Type DATETIME
    Weeks As Long
    Days As Long
    Hours As Long
    Minutes As Long
    Seconds As Long
End Type

Public Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(31) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(31) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Public Function TimeZoneBias() As String
On Error GoTo hErr
    Dim oTZI As TIME_ZONE_INFORMATION
    Dim DLSDate As String, STDDate As String, Bias As Long
    GetTimeZoneInformation oTZI
    DLSDate = oTZI.DaylightDate.wMonth & "/" & oTZI.DaylightDate.wDay & "/" & Year(Date) & Space$(1) & oTZI.DaylightDate.wHour & ":" & oTZI.DaylightDate.wMinute & ":" & oTZI.DaylightDate.wSecond
    STDDate = oTZI.StandardDate.wMonth & "/" & oTZI.StandardDate.wDay & "/" & Year(Date) & Space$(1) & oTZI.StandardDate.wHour & ":" & oTZI.StandardDate.wMinute & ":" & oTZI.StandardDate.wSecond
    If oTZI.DaylightDate.wMonth = 0 Then
        Bias = oTZI.Bias - oTZI.StandardBias
        GoTo SkipDST
    End If
    If DateDiff("s", Now, DLSDate) >= 0 Then
        If DateDiff("s", Now, STDDate) <= 0 Then
            Bias = oTZI.Bias - oTZI.DaylightBias
        Else
            Bias = oTZI.Bias - oTZI.StandardBias
        End If
    Else
        Bias = oTZI.Bias - oTZI.StandardBias
    End If
SkipDST:
    TimeZoneBias = Bias
    Exit Function
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "TimeZone", "TimeZoneBias"
End Function

Public Function GMTInverse(Num As Long) As String
    If Num < 0 Then
        GMTInverse = "+" & Abs(Num)
    ElseIf Num = 0 Then
        GMTInverse = vbNS
    Else
        GMTInverse = "-" & Abs(Num)
    End If
End Function

Public Function GetTimeZoneName() As String
    Dim tz As TIME_ZONE_INFORMATION, sRV As String
    Call GetTimeZoneInformation(tz)
    sRV = GetStrFromPtrW(VarPtr(tz.StandardName(0)))
    If InStrB(sRV, vbNullChar) <> 0 Then sRV = Left$(sRV, InStr(sRV, vbNullChar) - 1)
    GetTimeZoneName = sRV
End Function

' Returns the string up to the first Null Char
Public Function GetStrFromANSIBuffer(sBuf As String) As String
    If InStrB(sBuf, &H0) Then
        GetStrFromANSIBuffer = Left$(sBuf, InStr(sBuf, &H0) - 1)
    Else
        GetStrFromANSIBuffer = sBuf ' no null, so don't worry about it
    End If
End Function

' Return ANSI string from a pointer to a Unicode string.
Public Function GetStrFromPtrW(lpszW As Long) As String
    Dim sRV As String
    sRV = String$(lstrlenW(ByVal lpszW) * 2, &H0) ' 2 bytes/char
    ' copy from Unicode string into new buffer
    WideCharToMultiByte ACP, &H0, ByVal lpszW, -1, ByVal sRV, Len(sRV), &H0, &H0
    GetStrFromPtrW = GetStrFromANSIBuffer(sRV)
End Function

Public Function GetCurrentTimeBias() As String
   Dim tzi As TIME_ZONE_INFORMATION, dwBias As Long, tmp As String

   Select Case GetTimeZoneInformation(tzi)
   Case TIME_ZONE_ID_DAYLIGHT
      dwBias = tzi.Bias + tzi.DaylightBias
   Case Else
      dwBias = tzi.Bias + tzi.StandardBias
   End Select
   tmp = "GMT" & GMTInverse((CStr(dwBias \ 60))) & IIf((dwBias Mod 60) > 0, ":" & CStr(dwBias Mod 60), vbNS)
   GetCurrentTimeBias = tmp
End Function

Public Function ProcessTimeLogged(t As Long) As String
    Dim Days As Long, Hours As Long, Minutes As Long
    If t = 0 Then
        ProcessTimeLogged = "Unavailable"
    Else
        Days = t / 86400
        t = t Mod 86400
        Hours = t / 3600
        t = t Mod 3600
        Minutes = t / 60
        ProcessTimeLogged = Days & " days, " & Hours & " hours, " & Minutes & " minutes."
    End If
End Function

Public Function StringToFiletime(t As String) As FILETIME
    Dim Frag() As String, FT As FILETIME
    If LenB(t) = 0 Then StringToFiletime = FT: Exit Function
    Frag = Split(t, Space$(1))
    If (Val(Frag(0)) < 2 ^ 31) Then
        FT.dwHighDateTime = Val(Frag(0))
    Else
        FT.dwHighDateTime = Val(Frag(0)) - 2147483648# '2 ^ 32
    End If
    If UBound(Frag) > 0 Then
        If (Val(Frag(0)) > 0) And Val(Frag(0)) < 2 ^ 31 Then
            FT.dwLowDateTime = Val(Frag(0))
            FT.dwLowDateTime = FT.dwLowDateTime - 2147483648# '2 ^ 32
        Else
            FT.dwLowDateTime = Val(Frag(0))
        End If
    End If
    StringToFiletime = FT
End Function

Public Function ProcessSystemTime(t As SYSTEMTIME) As String
    On Error Resume Next
   ProcessSystemTime = WeekdayName(t.wDayOfWeek + 1, True) & Space$(1) & t.wDay & Space$(1) & MonthName(t.wMonth, True) & Space$(1) & t.wYear
   Dim Ap$
   If t.wHour > 12 Then
       t.wHour = t.wHour - 12
       Ap = "pm"
   Else
       Ap = "am"
   End If
   ProcessSystemTime = ProcessSystemTime & ", " & t.wHour & ":" & Format$(t.wMinute, "00") & _
       Ap
End Function

Public Function StringToSystemTimeString(S As String, Optional Default As String = "Never Played") As String
    If Len(Trim$(S)) = 0 Then
        StringToSystemTimeString = Default
    Else
        Dim FT As FILETIME, ST As SYSTEMTIME, LT As FILETIME
        FT = StringToFiletime(S)
        Call FileTimeToLocalFileTime(FT, LT)
        If FileTimeToSystemTime(LT, ST) Then
            StringToSystemTimeString = ProcessSystemTime(ST)
        Else
            StringToSystemTimeString = Default
        End If
    End If
End Function


Public Function DblTickCount() As Double
    #If Win16 Then
        DblTickCount = CDbl(GetTickCount())
    #Else
        Dim Cou As Currency, Fre As Currency
    On Error GoTo hErr
        If QueryPerformanceCounter(Cou) And QueryPerformanceFrequency(Fre) Then
            DblTickCount = Int(Cou / Fre * 1000)
        Else
            DblTickCount = LongToUnsigned(GetTickCount)
        End If
    #End If
    Exit Function
hErr:
    DblTickCount = CDbl(GetTickCount())
End Function

Private Function LongToUnsigned(Value As Long) As Double
    If Value < 0 Then
        LongToUnsigned = Value + 4294967296#
    Else
        LongToUnsigned = Value
    End If
End Function

Public Function DateTimeToShortestString(ByRef DT As DATETIME) As String
    Dim Buf As String
    Buf = Buf & Format$(DT.Days + IIf(DT.Weeks > 0, DT.Weeks * 7, 0), "00") & "|"
    Buf = Buf & Format$(DT.Hours, "00") & ":"
    Buf = Buf & Format$(DT.Minutes, "00") & ":"
    Buf = Buf & Format$(DT.Seconds, "00")
    DateTimeToShortestString = Buf
End Function

Public Function DateTimeToShortString(ByRef DT As DATETIME, Optional ByVal Seconds As Boolean = True) As String
    Dim Buf As String
    If (DT.Weeks) Then Buf = DT.Weeks & "w, "
    If (DT.Days) Then Buf = Buf & DT.Days & "d, "
    If (DT.Hours Or DT.Days) Then Buf = Buf & DT.Hours & "h, "
    If (DT.Hours Or DT.Days Or DT.Minutes) Then Buf = Buf & DT.Minutes & "m, "
    If Seconds Then
        Buf = Buf & DT.Seconds & "s"
    Else
        If Len(Buf) = 0 Then Buf = "<1m"
    End If
    If Right$(Buf, 2) = ", " Then Buf = Left$(Buf, Len(Buf) - 2)
    DateTimeToShortString = Buf
End Function

Public Function DateTimeToLongString(ByRef DT As DATETIME, Optional ByVal Seconds As Boolean = True) As String
    Dim Buf As String
    If (DT.Weeks) Then Buf = DT.Weeks & IIf(DT.Weeks = 1, " week, ", " weeks, ")
    If (DT.Days) Then Buf = Buf & DT.Days & IIf(DT.Days = 1, " day, ", " days, ")
    If (DT.Hours Or DT.Days) Then Buf = Buf & DT.Hours & IIf(DT.Hours = 1, " hour, ", " hours, ")
    If (DT.Hours Or DT.Days Or DT.Minutes) Then Buf = Buf & DT.Minutes & IIf(DT.Minutes = 1, " minute, ", " minutes, ")
    If Seconds Then
        Buf = Buf & IIf(Len(Buf) > 0, "and ", vbNS) & DT.Seconds & IIf(DT.Seconds = 1, " second", " seconds")
    Else
        If Len(Buf) = 0 Then Buf = "less than a minute"
    End If
    If Right$(Buf, 2) = ", " Then Buf = Left$(Buf, Len(Buf) - 2)
    DateTimeToLongString = Buf
End Function

Public Function ConvertTickCount(ByVal TickCount As Double) As DATETIME
On Error GoTo hErr
    Dim DT As DATETIME
    TickCount = TickCount / 1000
    DT.Days = Int(TickCount / 86400)
    TickCount = TickCount Mod 86400
    DT.Hours = Int(TickCount / 3600)
    TickCount = TickCount Mod 3600
    DT.Minutes = Int(TickCount / 60)
    TickCount = TickCount Mod 60
    DT.Seconds = TickCount
    DT.Weeks = DT.Days \ 7
    DT.Days = DT.Days Mod 7
    ConvertTickCount = DT
    Exit Function
hErr:
    ConvertTickCount = DT
    ErrorHandler Err.Number, Err.Description, Erl, "Time", "ConvertTickCount"
End Function

Private Function AusDate(ByVal wDay As Integer, wMonth As Integer, wYear As Integer) As String
    Dim Buffer As String, ST As SYSTEMTIME
    With ST
        .wDay = wDay
        .wMonth = wMonth
        .wYear = wYear
    End With
    Buffer = String(255, 0)
    GetDateFormat ByVal 3081, 0, ST, vbNS, Buffer, Len(Buffer)
    Buffer = Left$(Buffer, InStr(1, Buffer, Chr$(0)) - 1)
    AusDate = Buffer
End Function

Private Function IsLeapYear(ByVal yr As Integer) As Boolean
    IsLeapYear = Day(DateSerial(yr, 2, 29)) = 29
End Function

Private Function MonthDay(intMonth As Integer, intDayOfWeek As Integer, intWeekNum As Integer) As Boolean
    Dim strDay As String, intDay As Integer, intDays As Integer, intWeek As Integer
    Dim intWeekday As Integer
    
    'Determine how many days in month
    Select Case intMonth
    Case 1, 3, 5, 7, 8, 10, 12: intDays = 31
    Case 4, 6, 9, 11:           intDays = 30
    Case 2:                     If IsLeapYear(Year(Date)) Then intDays = 29 Else intDays = 28
    End Select

    'Find weekday in question
    For intDay = 1 To intDays
        strDay = AusDate(intDay, intMonth, Year(Date))
        intWeekday = Weekday(strDay)
        If intWeekday = intDayOfWeek Then
            intWeek = intWeek + 1
            If intWeek = intWeekNum Then
                If AusDate(Day(Date), Month(Date), Year(Date)) = strDay Then
                    MonthDay = True
                    Exit For
                End If
            End If
        End If
    Next
End Function

Private Function IsToday(d1 As String, d2 As String) As Boolean
    IsToday = (d1 = d2)
End Function

Public Sub EasterDate(d As Integer, M As Integer, y As Integer)
   Dim FirstDig, Remain19, Temp    'intermediate results
   Dim tA, tB, tC, tD, tE          'table A to E results

   FirstDig = y \ 100              'first 2 digits of year
   Remain19 = y Mod 19             'remainder of year / 19

' calculate PFM date
   Temp = (FirstDig - 15) \ 2 + 202 - 11 * Remain19
    
   Select Case FirstDig
      Case 21, 24, 25, 27 To 32, 34, 35, 38
         Temp = Temp - 1
      Case 33, 36, 37, 39, 40
         Temp = Temp - 2
   End Select
   Temp = Temp Mod 30

   tA = Temp + 21
   If Temp = 29 Then tA = tA - 1
   If (Temp = 28 And Remain19 > 10) Then tA = tA - 1

'find the next Sunday
   tB = (tA - 19) Mod 7
    
   tC = (40 - FirstDig) Mod 4
   If tC = 3 Then tC = tC + 1
   If tC > 1 Then tC = tC + 1
        
   Temp = y Mod 100
   tD = (Temp + Temp \ 4) Mod 7
   
   tE = ((20 - tB - tC - tD) Mod 7) + 1
   d = tA + tE

   If d > 31 Then
      d = d - 31
      M = 4
   Else
      M = 3
   End If
End Sub

Public Function DateSignificance() As String
    'Check variable dates
    Select Case Month(Date)
    Case 1
        If Day(Date) = 1 Then DateSignificance = "Happy New Year!": Exit Function
    Case 12
        Select Case Day(Date)
        Case 25: DateSignificance = "Merry Christmas!": Exit Function
        Case 26: DateSignificance = "Boxing Day!": Exit Function
        Case 24: DateSignificance = "Christmas Eve!": Exit Function
        Case 31: DateSignificance = "New Years Eve!": Exit Function
        End Select
    End Select
    
    'Finally check if easter or celebrated easter date
    Dim eDay As Integer, eMonth As Integer
    EasterDate eDay, eMonth, CInt(Year(Date))
    If IsToday(AusDate(Day(Date), Month(Date), Year(Date)), AusDate(eDay, eMonth, Year(Date))) Then DateSignificance = "Happy Easter!": Exit Function
    If IsToday(AusDate(Day(Date), Month(Date), Year(Date)), AusDate(eDay + 1, eMonth, Year(Date))) Then DateSignificance = "Easter Monday!": Exit Function
    If IsToday(AusDate(Day(Date), Month(Date), Year(Date)), AusDate(eDay - 7, eMonth, Year(Date))) Then DateSignificance = "Palm Sunday!": Exit Function
    If IsToday(AusDate(Day(Date), Month(Date), Year(Date)), AusDate(eDay - 1, eMonth, Year(Date))) Then DateSignificance = "Holy Saturday!": Exit Function
    If IsToday(AusDate(Day(Date), Month(Date), Year(Date)), AusDate(eDay - 2, eMonth, Year(Date))) Then DateSignificance = "Good Friday!": Exit Function
    If IsToday(AusDate(Day(Date), Month(Date), Year(Date)), AusDate(eDay - 3, eMonth, Year(Date))) Then DateSignificance = "Maudy Thursday!": Exit Function
End Function
