I have Vba macro windows Form application, And I need to retrieve a datetime from an api which is retrieved as UTC date like(2022-03-28T22:34:48Z) and when I'm trying to get the value like this:
On Error GoTo ErrorHandler:
For Each obj In Parsed("rows")
with Support
.SupportEndDate = obj("supportenddate")
End With
Next obj
ErrorHandler:
Err.Clear
Resume Next
the debugger is moving to the ErrorHandler and the value doesn't set, and also I tried to add CDate function before obj("supportenddate") but it's still not working
note: .SupportEndDate is a Date type, and when I added a watch to see the value of obj("supportenddate") I found that it's a variant/string
CodePudding user response：
This will attempt to convert it to a date from a string, but it will work only when it's in that T/Z format:
Function UTC2Date(s As String) As Variant
' example argument
' "2022-03-28T22:34:48Z"
If InStr(s, "T") > 0 And InStr(s, "Z") > 0 Then
UTC2Date = CDate(Split(s, "T")(0) & " " & Replace(Split(s, "T")(1), "Z", ""))
Else
UTC2Date = "ERROR"
End If
End Function
CodePudding user response：
The following solution works on both Windows and Mac and does not use any APIs:
Option Explicit
Private Type TIME_OFFSET
offsetSign As Integer
localOffsetPart As String
End Type
Private Type TIME_PART
sValue As String
hasFractionalPart As Boolean
secsFractionalPart As String
hasOffset As Boolean
timeOffset As TIME_OFFSET
End Type
Private Type ISO_PARTS
datePart As String
hasTime As Boolean
timePart As TIME_PART
End Type
'Expecting:
' - Complete Date:
' YYYY-MM-DD (eg 1997-07-16)
' - Complete date plus hours, minutes and seconds:
' YYYY-MM-DDThh:mm:ssTZD (eg 1997-07-16T19:20:30 01:00)
' - Complete date plus hours, minutes and seconds with a fractional part
' YYYY-MM-DDThh:mm:ss.sTZD (eg 1997-07-16T19:20:30.45 01:00)
'where:
' YYYY = four-digit year
' MM = two-digit month (01=January, etc.)
' DD = two-digit day of month (01 through 31)
' hh = two digits of hour (00 through 23) (am/pm NOT allowed)
' mm = two digits of minute (00 through 59)
' ss = two digits of second (00 through 59)
' s = one or more digits representing a decimal fraction of a second
' TZD = time zone designator (Z or hh:mm or -hh:mm)
' Z - UTC designator
' " " or "-" - local time zone offset (in hours and minutes)
Public Function ISOToUTC(ByVal isoDateTime As String) As Date
Const methodName As String = "ISOToUTC"
'
If LenB(isoDateTime) = 0 Then Err.Raise 5, methodName, "Empty ISO string"
'
Dim regEx As Object: Set regEx = GetRegEx()
Dim isoParts As ISO_PARTS
'
On Error Resume Next
If regEx Is Nothing Then
isoParts = ISOLike(isoDateTime)
Else
isoParts = ISORegEx(regEx, isoDateTime)
End If
If Err.Number <> 0 Then
Dim errDesc As String: errDesc = Err.Description
On Error GoTo 0
Err.Raise 5, methodName, errDesc
End If
'
'Date and/or time could be invalid even if the pattern returned a result
'Ex. Date 2017-12-41 or Time 25:14:78
'
Dim dt As Date
'
dt = CDate(isoParts.datePart)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Raise 5, methodName, "Invalid ISO string. Invalid date digits"
End If
If isoParts.hasTime Then
With isoParts.timePart
dt = dt CDate(.sValue)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Raise 5, methodName, "Invalid ISO string. Invalid time digits"
End If
If .hasFractionalPart Then
Const secondsPerDay As Long = 24& * 60& * 60&
dt = dt CDbl(.secsFractionalPart) / secondsPerDay
End If
If .hasOffset Then
dt = dt .timeOffset.offsetSign * CDate(.timeOffset.localOffsetPart)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Raise 5, methodName, "Invalid ISO string. Invalid timezone offset"
End If
End If
End With
End If
On Error GoTo 0
'
ISOToUTC = dt
End Function
'https://www.regular-expressions.info/vbscript.html
Private Function GetRegEx() As Object
On Error Resume Next 'Use Late Binding to get the available RegExp library
Set GetRegEx = CreateObject("VBScript.RegExp")
On Error GoTo 0
End Function
Private Function ISORegEx(ByVal regEx As Object _
, ByVal isoDateTime As String) As ISO_PARTS
Const pDesignatorSign As String = "(\ |-)"
Const pLocalDesignator As String = "(" & pDesignatorSign & "\d{2}:\d{2})"
Const pZoneDesignator As String = "(Z|" & pLocalDesignator & ")"
Const pDecimal As String = "(.{1}\d )?"
Const pTime As String = "(T\d{2}:\d{2}:\d{2}" & pDecimal & pZoneDesignator & ")?"
Const pDate As String = "\d{4}-\d{2}-\d{2}"
Const pISO As String = "^" & pDate & pTime & "$"
Dim subGroups As Object
'
With regEx
.Global = False
.IgnoreCase = False
.Pattern = pISO
With .Execute(isoDateTime)
If .Count = 0 Then Err.Raise 5, , "Invalid ISO string"
Set subGroups = .Item(0).SubMatches
End With
End With
With ISORegEx
.datePart = Left$(isoDateTime, 10)
.hasTime = Not IsEmpty(subGroups.Item(0))
If Not .hasTime Then Exit Function
End With
With ISORegEx.timePart
.sValue = Replace(subGroups.Item(0), "T", vbNullString)
.hasFractionalPart = Not IsEmpty(subGroups.Item(1))
If .hasFractionalPart Then
.secsFractionalPart = subGroups.Item(1)
.sValue = Replace(.sValue, .secsFractionalPart, vbNullString)
End If
'Remove the time zone designator (Z or offset) from the time part
.sValue = Replace(.sValue, subGroups.Item(2), vbNullString)
.hasOffset = Not IsEmpty(subGroups.Item(4))
If Not .hasOffset Then Exit Function
End With
With ISORegEx.timePart.timeOffset
Dim offsetSign As String: offsetSign = subGroups.Item(4)
.localOffsetPart = Replace(subGroups.Item(3), offsetSign, vbNullString)
.offsetSign = IIf(offsetSign = " ", 1, -1)
End With
End Function
Private Function ISOLike(ByVal isoDateTime As String) As ISO_PARTS
Dim dateTimeParts() As String
'
dateTimeParts = Split(isoDateTime, "T")
Select Case UBound(dateTimeParts, 1) - LBound(dateTimeParts, 1) 1
Case 1
ISOLike.hasTime = False
Case 2
ISOLike.hasTime = True
ISOLike.timePart.sValue = dateTimeParts(UBound(dateTimeParts, 1))
Case Else
Err.Raise 5, , "Invalid ISO string. Multiple 'T' separators"
End Select
ISOLike.datePart = dateTimeParts(LBound(dateTimeParts, 1))
'
If Not ISOLike.datePart Like "####-##-##" Then
Err.Raise 5, , "Invalid ISO string. Invalid Date part"
End If
If Not ISOLike.hasTime Then Exit Function
If Not ISOLike.timePart.sValue Like "##:##:##[.,Z, ,-]*" Then
Err.Raise 5, , "Invalid ISO string. Invalid Time part"
End If
'
With ISOLike.timePart
If Mid$(.sValue, 9, 1) = "." Then 'Remove fractional part first
.hasFractionalPart = True
If Not .sValue Like "##:##:##.#*[Z, ,-]*" Then
Err.Raise 5, , "Invalid ISO string. Invalid Time Fractional part"
End If
'
Dim fractEnd As Long: fractEnd = InStr(10, .sValue, "Z")
If fractEnd = 0 Then fractEnd = InStr(10, .sValue, " ")
If fractEnd = 0 Then fractEnd = InStr(10, .sValue, "-")
'
.secsFractionalPart = Mid$(.sValue, 9, fractEnd - 9)
'
Dim fracPattern As String
fracPattern = "." & String$(Len(.secsFractionalPart) - 1, "#")
'
If Not .secsFractionalPart Like fracPattern Then
Err.Raise 5, , "Invalid ISO string. Invalid Time Fractional part"
End If
'
'Replace first occurence only to avoid cases like: 12:12:12.451Z.451
.sValue = Replace(.sValue, .secsFractionalPart, vbNullString, 1, 1)
End If
'
Select Case Mid$(.sValue, 9, 1)
Case "Z"
.hasOffset = False
If Len(.sValue) > 9 Then
Err.Raise 5, , "Invalid ISO string. Extra characters after 'Z'"
End If
Case " "
.hasOffset = True
.timeOffset.offsetSign = 1
Case "-"
.hasOffset = True
.timeOffset.offsetSign = -1
End Select
'
If .hasOffset Then
If Not .sValue Like "##:##:##[ ,-]##:##" Then
Err.Raise 5, , "Invalid ISO string. Invalid timezone offset"
Else
.timeOffset.localOffsetPart = Right$(.sValue, 5)
End If
End If
.sValue = Left$(.sValue, 8)
End With
End Function
Here is a quick test:
Sub TestISOToUTC()
Debug.Assert ISOToUTC("2022-03-28") = DateSerial(2022, 3, 28)
Debug.Assert ISOToUTC("2022-03-28T22:34:48Z") = DateSerial(2022, 3, 28) TimeSerial(22, 34, 48)
Debug.Assert ISOToUTC("2022-03-28T22:34:48 01:00") = DateSerial(2022, 3, 28) TimeSerial(23, 34, 48)
Debug.Assert ISOToUTC("2022-03-28T22:34:48-01:00") = DateSerial(2022, 3, 28) TimeSerial(21, 34, 48)
Debug.Assert ISOToUTC("2022-03-28T22:34:48.45 01:00") = DateSerial(2022, 3, 28) TimeSerial(23, 34, 48) TimeSerial(0, 0, 1) * 0.45
End Sub
The regEx solution is more compact but the Like solution is around 300 times faster. So, you could remove the regEx logic if you wish and it will still work on both Win and Mac.