181 lines
6.5 KiB
QBasic
181 lines
6.5 KiB
QBasic
Attribute VB_Name = "ex_Time"
|
|
' ======== Time conversion ========
|
|
' Shared module version: 20210630
|
|
' Tested in:
|
|
' Depends on:
|
|
' Required reference:
|
|
Option Private Module
|
|
Option Explicit
|
|
|
|
''
|
|
' VBA-UTC v1.0.6
|
|
' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter
|
|
' UTC/ISO 8601 Converter for VBA
|
|
' @license MIT (http://www.opensource.org/licenses/mit-license.php)
|
|
'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
|
|
|
|
Private Declare PtrSafe Function UTC_GetTimeZoneInfo Lib "kernel32" Alias "GetTimeZoneInformation" _
|
|
(utc_lpTimeZoneInformation As TTimeZone) As Long
|
|
Private Declare PtrSafe Function UTC_SystemTimeToLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _
|
|
(utc_lpTimeZoneInformation As TTimeZone, utc_lpUniversalTime As TSystemTime, utc_lpLocalTime As TSystemTime) As Long
|
|
Private Declare PtrSafe Function UTC_LocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _
|
|
(utc_lpTimeZoneInformation As TTimeZone, utc_lpLocalTime As TSystemTime, utc_lpUniversalTime As TSystemTime) As Long
|
|
|
|
Private Type TSystemTime
|
|
utc_wYear As Integer
|
|
utc_wMonth As Integer
|
|
utc_wDayOfWeek As Integer
|
|
utc_wDay As Integer
|
|
utc_wHour As Integer
|
|
utc_wMinute As Integer
|
|
utc_wSecond As Integer
|
|
utc_wMilliseconds As Integer
|
|
End Type
|
|
|
|
Private Type TTimeZone
|
|
utc_Bias As Long
|
|
utc_StandardName(0 To 31) As Integer
|
|
utc_StandardDate As TSystemTime
|
|
utc_StandardBias As Long
|
|
utc_DaylightName(0 To 31) As Integer
|
|
utc_DaylightDate As TSystemTime
|
|
utc_DaylightBias As Long
|
|
End Type
|
|
|
|
Private Const ERR_UTC_PARSE_FAIL = vbObjectError + 1025
|
|
Private Const ERR_UTC_CONVERSION_FAIL = vbObjectError + 1026
|
|
Private Const ERR_ISO_PARSE_FAIL = vbObjectError + 1027
|
|
Private Const ERR_ISO_CONVERSION_FAIL = vbObjectError + 1028
|
|
|
|
' Parse UTC date to local date
|
|
Public Function ParseUtc(utc_UtcDate As Date) As Date
|
|
On Error GoTo ON_ERROR
|
|
|
|
Dim utc_TimeZoneInfo As TTimeZone
|
|
Dim utc_LocalDate As TSystemTime
|
|
|
|
Call UTC_GetTimeZoneInfo(utc_TimeZoneInfo)
|
|
Call UTC_SystemTimeToLocalTime(utc_TimeZoneInfo, UTC_DateToSystemTime(utc_UtcDate), utc_LocalDate)
|
|
|
|
ParseUtc = UTC_SystemTimeToDate(utc_LocalDate)
|
|
Exit Function
|
|
|
|
ON_ERROR:
|
|
Call Err.Raise(ERR_UTC_PARSE_FAIL, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description)
|
|
End Function
|
|
|
|
' Convert local date to UTC date
|
|
Public Function ConvertToUtc(utc_LocalDate As Date) As Date
|
|
On Error GoTo ON_ERROR
|
|
|
|
Dim utc_TimeZoneInfo As TTimeZone
|
|
Dim utc_UtcDate As TSystemTime
|
|
|
|
UTC_GetTimeZoneInfo utc_TimeZoneInfo
|
|
UTC_LocalTimeToSystemTime utc_TimeZoneInfo, UTC_DateToSystemTime(utc_LocalDate), utc_UtcDate
|
|
|
|
ConvertToUtc = UTC_SystemTimeToDate(utc_UtcDate)
|
|
Exit Function
|
|
|
|
ON_ERROR:
|
|
Call Err.Raise(ERR_UTC_PARSE_FAIL, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description)
|
|
End Function
|
|
|
|
' Parse ISO 8601 date string to local date
|
|
Public Function ParseIso(sISOTime$) As Date
|
|
On Error GoTo ON_ERROR
|
|
|
|
Dim utc_Parts() As String
|
|
Dim utc_DateParts() As String
|
|
Dim utc_TimeParts() As String
|
|
Dim utc_OffsetIndex&
|
|
Dim utc_HasOffset As Boolean
|
|
Dim utc_NegativeOffset As Boolean
|
|
Dim utc_OffsetParts() As String
|
|
Dim utc_Offset As Date
|
|
|
|
utc_Parts = VBA.Split(sISOTime, "T")
|
|
utc_DateParts = VBA.Split(utc_Parts(0), "-")
|
|
ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2)))
|
|
|
|
If UBound(utc_Parts) > 0 Then
|
|
If VBA.InStr(utc_Parts(1), "Z") Then
|
|
utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":")
|
|
Else
|
|
utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+")
|
|
If utc_OffsetIndex = 0 Then
|
|
utc_NegativeOffset = True
|
|
utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-")
|
|
End If
|
|
|
|
If utc_OffsetIndex > 0 Then
|
|
utc_HasOffset = True
|
|
utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":")
|
|
utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":")
|
|
|
|
Select Case UBound(utc_OffsetParts)
|
|
Case 0
|
|
utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0)
|
|
Case 1
|
|
utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0)
|
|
Case 2
|
|
' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
|
|
utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2))))
|
|
End Select
|
|
|
|
If utc_NegativeOffset Then: utc_Offset = -utc_Offset
|
|
Else
|
|
utc_TimeParts = VBA.Split(utc_Parts(1), ":")
|
|
End If
|
|
End If
|
|
|
|
Select Case UBound(utc_TimeParts)
|
|
Case 0
|
|
ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0)
|
|
Case 1
|
|
ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0)
|
|
Case 2
|
|
' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues
|
|
ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2))))
|
|
End Select
|
|
|
|
ParseIso = ParseUtc(ParseIso)
|
|
|
|
If utc_HasOffset Then
|
|
ParseIso = ParseIso - utc_Offset
|
|
End If
|
|
End If
|
|
|
|
Exit Function
|
|
|
|
ON_ERROR:
|
|
Err.Raise ERR_ISO_PARSE_FAIL, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & sISOTime & ": " & Err.Number & " - " & Err.Description
|
|
End Function
|
|
|
|
' Convert local date to ISO 8601 string
|
|
Public Function ConvertToIso(utc_LocalDate As Date) As String
|
|
On Error GoTo ON_ERROR
|
|
ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z")
|
|
Exit Function
|
|
|
|
ON_ERROR:
|
|
Call Err.Raise(ERR_ISO_CONVERSION_FAIL, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description)
|
|
End Function
|
|
|
|
' =============================================
|
|
Private Function UTC_DateToSystemTime(utc_Value As Date) As TSystemTime
|
|
UTC_DateToSystemTime.utc_wYear = VBA.Year(utc_Value)
|
|
UTC_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value)
|
|
UTC_DateToSystemTime.utc_wDay = VBA.Day(utc_Value)
|
|
UTC_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value)
|
|
UTC_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value)
|
|
UTC_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value)
|
|
UTC_DateToSystemTime.utc_wMilliseconds = 0
|
|
End Function
|
|
|
|
Private Function UTC_SystemTimeToDate(utc_Value As TSystemTime) As Date
|
|
UTC_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _
|
|
TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond)
|
|
End Function
|
|
|