Option Explicit

Class ISO8601
''
'This class provides handling for ISO8601 format Date strings as might be found in XML data or elsewhere
'
'@author	Bob Stammers saphena@compuserve.com
'@version	2006-04-20


' METHODS
'Public Function toDate(ByVal sIsoDatetime)
'Public Function toTime(ByVal sIsoDatetime)
'Public Function toDatetime(ByVal sIsoDatetime)
'Public Function FractionalSeconds(sIsoDatetime)
'Public Sub SplitIso(ByVal sIsoDatetime,ByRef sIsoDate,ByRef sIsoTime,ByRef sTZ)
'Public Function Compare(ByVal sIso1,ByVal sIso2)
'Public Function AdjustedToZ(ByVal sIsoDatetime)
'Public Function isValidDate(ByVal sIsoDatetime)
'Public Function isComplete(ByVal sIsoDatetime)
'Public Function isValid(ByVal sIsoDatetime)
'Public Function toIsoDatetime(ByVal vDatetime) 
'Public Function toIsoDate(ByVal vDatetime)
'Public Function toIsoTime(ByVal vDatetime) 
'
' PROPERTIES
'Public Property Let strTimezone(ByVal sZone)
'Public Property Get strTimezone
'Public Property Get intTimezoneMins
'Public Property Get intTimezoneHours
'
' ERRORS
' Error 13 (normally "Type mismatch") is raised by toDate and toDatetime if parameter does not contain
' at least a valid year specification.  The error source will be "ISO8601.toDate" and the error description
' will be "Argument does not contain a valid ISO string"


'The formats are as follows. Exactly the components shown here must be present, with exactly this punctuation. 
'Note that the "T" appears literally in the string, to indicate the beginning of the Time element, as specified in ISO 8601.
'
'   Year:
'      YYYY (eg 1997);
'   Year and month:
'      YYYY-MM (eg 1997-07);
'   Complete Date:
'      YYYY-MM-DD (eg 1997-07-16);
'   Complete Date plus hours and minutes:
'      YYYY-MM-DDThh:mmTZD (eg 1997-07-16T19:20+01:00);
'   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, seconds and a decimal fraction of a second
'      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)
'
'@author	Bob Stammers saphena@compuserve.com
'


''
'Used when making ISO strings
'@remarks This is initialised to the host machine's timezone if obtainable from WMI otherwise set to Z
Private CurrentTimezone

''
'This regular expression is used to test for a complete ISO datetime
Private RE_Complete

''
'This regular expression is used to test for a valid timezone component of an ISO string
Private RE_Timezone

''
'This regular expression is used to test for any valid ISO string
Private RE_Valid



''
'Converts a valid ISO datetime string into VB variant date with no time component.  Short forms are sensibly defaulted
'
'@param	sIsoDatetime
'@return	Standard VB datetime
'@remarks	This will raise error 13 (Type Mismatch) if no valid ISO string is supplied
Public Function toDate(ByVal sIsoDatetime)

Dim yy,mm,dd

	'On Error Resume next

	mm = 1 : dd = 1
	If Len(sIsoDatetime) < 4 Then 
		Err.Raise 13,"ISO8601.toDate","Argument does not contain a valid ISO string"
		Exit Function
	End If
	yy = CInt(Mid(sIsoDatetime,1,4))
	If Len(sIsoDatetime) >= 7 Then
		mm = CInt(Mid(sIsoDatetime,6,2))
		If Len(sIsoDatetime) >= 10 Then
			dd = CInt(Mid(sIsoDatetime,9,2))
		End If
	End If
	toDate = DateSerial(yy,mm,dd)

	End Function

''
'Extract the time part from an ISO string and return it in VB form
'NB fractions of a second are not converted, the resulting time will be truncated to hh:mm:ss
'@param	sIsoDatetime
'@return	VB time
'@remarks	See FractionalSeconds for handling of fractions of a second
Public Function toTime(ByVal sIsoDatetime)

Dim hh,mm,ss,p

	On Error Resume next
	
	hh = 0 : mm = 0 : ss = 0
	If Len(sIsoDatetime) >= 13 Then
		hh = CInt(Mid(sIsoDatetime,12,2))
		If Len(sIsoDatetime) >= 16 Then
			mm = CInt(Mid(sIsoDatetime,15,2))
			If Len(sIsoDatetime) >= 19 Then
				ss = CInt(Mid(sIsoDatetime,18,2))
			End If
		End If
	End If
	toTime = TimeSerial(hh,mm,ss)

End Function


''
'Convert a full ISO datetime string into VB variant
'
'@param	sIsoDatetime
'@return	VB datetime
Public Function toDatetime(ByVal sIsoDatetime)

	toDatetime = toDate(sIsoDatetime) + toTime(sIsoDatetime)

End Function

''
'Recover seconds including any fractional part from complete string
'
'@param sIsoDatetime	Full ISO date/time string
'@return	Double containing seconds component of time specification including any fractional part
'@remarks	VB doesn't handle fractions of a second in its datetime calculations so this function enables separate handling of fractional parts
Public Function FractionalSeconds(sIsoDatetime)

Dim p

	If Len(sIsoDatetime) < 20 Then    ' not long enough to include seconds
		FractionalSeconds = CDbl(0)
		Exit Function
	End If
	If Mid(sIsoDatetime,20,1) <> "." Then
		FractionalSeconds = CDbl(Mid(sIsoDatetime,18,2))
		Exit Function
	End If
	p = 21
	Do While p <= Len(sIsoDatetime)
		If Mid(sIsoDatetime,p,1) >= "0" and Mid(sIsoDatetime,p,1) <= "9" Then
			p = p + 1
		Else
			Exit Do
		End If
	Loop
	FractionalSeconds = CDbl(Mid(sIsoDatetime,18,p-18))
	
End Function


''
' Takes a complete ISO Datetime string and breaks out its Date, Time and timezone components
'
'@param	sIsoDatetime	Input Full ISO datetime string
'@param	sIsoDate		Output ISO date component
'@param	sIsoTime		Output ISO time component
'@param	sTZ			Output ISO timezone
Public Sub SplitIso(ByVal sIsoDatetime,ByRef sIsoDate,ByRef sIsoTime,ByRef sTZ)

Dim p
	
	sIsoTime = "00:00": sTZ = "Z"
	If Len(sIsoDatetime) > 10 Then
		sIsoDate = Left(sIsoDatetime,10)
	Else
		sIsoDate = sIsoDatetime
		Exit Sub
	End If
	p = Len(sIsoDatetime)
	Do While (p > 12)
		Select Case Mid(sIsoDatetime,p,1)
			Case "+", "-", "Z"
				Exit Do
		End Select
		p = p - 1
	Loop
	sTZ = Mid(sIsoDatetime,p)
	sIsoTime = Mid(sIsoDatetime,12,p - 12)
	
End Sub

''
' Compares two ISO datetimes, adjusting for timezone differences
'
'@param	sIso1
'@param	sIso2
'@return	1 = sIso1 > sIso2; -1 = sIso1 < sIso2; 0 = sIso1 = sIso2
Public Function Compare(ByVal sIso1,ByVal sIso2)

Dim d1,t1,z1,d2,t2,z2

	SplitIso sIso1,d1,t1,z1
	SplitIso sIso2,d2,t2,z2
	If strComp(z1,z2) = 0 Then
		Compare = strComp(sIso1,sIso2)
	Else
		Compare = strComp(AdjustedToZ(sIso1),AdjustedToZ(sIso2))
	End If

End Function

''
'This returns the input ISO string adjusted to UTC/GMT
'
'@param	sIsoDatetime
'@return	Full ISO datetime
'@remarks	This will convert strings which specify a timezone of +00:00 or -00:00 to ones marked with Z instead
Public Function AdjustedToZ(ByVal sIsoDatetime)
'
' Return ISO string expressed relative to GMT
'
Dim dt,ti,tz
Dim hh

	SplitIso sIsoDatetime,dt,ti,tz
	If (tz = "Z") Then
		AdjustedToZ = sIsoDatetime
		Exit Function
	End If
	If (Right(tz,5) = "00:00") Then
		AdjustedToZ = Left(sIsoDatetime,Len(sIsoDatetime)-6) & "Z"
		Exit Function
	End If
	
	hh = CInt(Mid(tz,2,2))	' Offset from Z
	If Left(tz,1) = "+" Then hh = 0 - hh
	
	tz = CurrentTimezone
	CurrentTimezone = "Z"
	AdjustedToZ = toIsoDatetime(DateAdd("h",hh,toDatetime(sIsoDatetime)))
	CurrentTimezone = tz
	
End Function

''
'Tests for a strictly valid ISO format complete date in the form YYYY-MM-DD
'@param	sIsoDatetime
'@return	True or False
Public Function isValidDate(ByVal sIsoDatetime)

	isValidDate = False
	If Len(sIsoDatetime) >= 10 Then
	 If IsNumeric(Mid(sIsoDatetime,1,4)) and _
		(Mid(sIsoDatetime,5,1) = "-") and isValidNum(Mid(sIsoDatetime,6,2),1,12) and _
		(Mid(sIsoDatetime,8,1) = "-") and isValidNum(Mid(sIsoDatetime,9,2),1,31) Then
		isValidDate = True
	 End If
	End If
	
End Function

''
'Validity test for the most common requirement, a fully qualified ISO datetime string
'
'String must be comprised of YYYY-MM-DDTHH:MMTZD and may also contain seconds and fractions
'
'@param	sIsoDatetime
'@return	True or False
Public Function isComplete(ByVal sIsoDatetime)

Dim Ms, M, S

	Set Ms = RE_Complete.Execute(sIsoDatetime)
	isComplete = False
	For Each M in Ms ' 0 or 1 occurrences
		isComplete = True
		'
		' I suppose this really should rangecheck the parts as well but what the heck!
		'
	Next
		
End Function


''
'Tests for a valid ISO string.  Will accept any of the legal short forms such as YYYY, YYYY-MM, etc
'@param	sIsoDatetime
'@return	True or False
Public Function isValid(ByVal sIsoDatetime)
'
' Returns true only if string conforms to specification
'

Dim Ms, M

	Set Ms = RE_Valid.Execute(sIsoDatetime)
	isValid = False
	For Each M in Ms ' 0 or 1 occurrences
		isValid = True
		'
		' I suppose this really should rangecheck the parts as well but what the heck!
		'
	Next

End Function

	
''
'Sets the current timezone string
'
'@param	sZone	 either +hh:mm or the literal "Z"
Public Property Let strTimezone(ByVal sZone)

	If isValidTZ(sZone) Then CurrentTimezone = sZone
	
End Property

''
'Returns current timezone string
'
'@return	+hh:mm
Public Property Get strTimezone

	strTimezone = CurrentTimezone
	
End Property

''
' Returns current timezone offset in minutes
'
'@return timezone offset in minutes
'
Public Property Get intTimezoneMins

Dim res

	If CurrentTimezone = "Z" Then
		intTimezone = 0
		Exit Property
	End If
	
	res = (CInt(Mid(CurrentTimezone,2,2)) * 60) + CInt(Mid(CurrentTimezone,5,2))
	If Left(CurrentTimezone,1) = "-" Then
		intTimezone = 0 - res
	Else
		intTimezone = res
	End If
	
End Property

''
' Returns current timezone offset in hours
'
'@return timezone offset in hours
'
Public Property Get intTimezoneHours

Dim res

	If CurrentTimezone = "Z" Then
		intTimezone = 0
		Exit Property
	End If
	
	res = CInt(Mid(CurrentTimezone,2,2))
	If Left(CurrentTimezone,1) = "-" Then
		intTimezone = 0 - res
	Else
		intTimezone = res
	End If
	
End Property

''
'Convert full datetime from VB to ISO
'@param	vDatetime	Standard VB date/time variant
'@return	Fully qualified ISO datetime string
'
Public Function toIsoDatetime(ByVal vDatetime) 

	toIsoDatetime = toIsoDate(vDatetime) & "T" & toIsoTime(vDatetime) & CurrentTimezone
	
End Function
	

'' 
'Extract time part of VB datetime and return only ISO formatted date string; no time or timezone
'@param	vDatetime	Standard VB date/time variant
'@return	yyyy-mm-dd
'
Public Function toIsoDate(ByVal vDatetime)

Dim yy, mm, dd

	yy = Year(vDatetime)
	mm = Month(vDatetime)
	dd = Day(vDatetime)
	toIsoDate = CStr(yy) & "-" & strN2(mm) & "-" & strN2(dd)
	
End Function	


'' 
'Extract time part of VB datetime and return only ISO formatted timestring without timezone appended
'@param	vDatetime	Standard VB date/time variant
'@return	hh:mm:ss
'
Public Function toIsoTime(ByVal vDatetime) 

Dim hh, mins, ss

	hh = Hour(vDatetime)
	mins = Minute(vDatetime)
	ss = Second(vDatetime)
	toIsoTime = strN2(hh) & ":" & strN2(mins) & ":" & strN2(ss)
	
End Function

Private Function isValidNum(ByVal sN,ByVal iLo,ByVal iHi)

	If IsNumeric(sN) Then
		If (CInt(sN) >= iLo) And (Cint(sN) <= iHi) Then
			isValidNum = True
		End If
	End If
	
End Function


Private Function isValidTZ(ByVal sTimezone)

Dim Ms,M,S

	' This returns a Match object if the timezone is valid. The match has three SubMatches
	' being: the whole string, the hours and the minutes
	Set Ms = RE_Timezone.Execute(sTimezone)
	isValidTZ = False
	For Each M in Ms ' There will be either 0 or 1 matches
		If M.SubMatches(0) = "Z" Then
			isValidTZ = True
		Else
			isValidTZ = isValidNum(M.SubMatches(1),0,13) and isValidNum(M.SubMatches(2),0,59)
		End If
	Next
	
End Function

Private Sub Class_Initialize

Dim os, x

	On Error Resume Next
	
	Set RE_Complete = New RegExp
	Set RE_Timezone = New RegExp
	Set RE_Valid	= New RegExp
	
	RE_Timezone.Pattern = "(\Z|[\+\-](\d{2})\:(\d{2}))"
	RE_Complete.Pattern = "^(\d{4}\-\d{2}\-\d{2})\T(\d{2}\:\d{2}(|\:\d{2}(|\.\d*)))" & RE_Timezone.Pattern & "$"
	RE_Valid.Pattern	= "^\d{4}(|\-\d{2}(|\-\d{2}(|T\d{2}(|\:\d{2}(|:\d{2}(|\.\d*)))" & RE_Timezone.Pattern & ")))$"
	
	strTimezone = "Z"

	'Get the actual offset from WMI
	For Each os In GetObject("winmgmts:").InstancesOf ("Win32_OperatingSystem")
		x = right("00" & os.CurrentTimeZone/60,2) & ":" & right("00" & os.CurrentTimeZone mod 60, 2)
		If Left(x,1) <> "-" Then x = "+" & x
		strTimezone = x
	Next	
	
End Sub

Private Sub Class_Terminate

	Set RE_Valid	= Nothing
	Set RE_Timezone	= Nothing
	Set RE_Complete	= Nothing
	
End Sub
	
''
' Returns a two digit number
'@param intN
'@return 2 digit string
Private Function strN2(intN)

Dim x

	x = CStr(intN)
	If Len(x) < 2 Then
		x = "0" & x
	End If
	strN2 = x
	
End Function
	


	
End Class

Sub TestHarness

Dim iso, dt, x, testdate1, testdate2, testdate3, i, t1, t2

	Set iso = New ISO8601
	
	dt = Now

	WScript.Echo "Standard Date/Time = " & FormatDatetime(dt)
	x = iso.toIsoDatetime(dt)
	WScript.Echo "   ISO8601 version = " & x
	WScript.Echo "    Converted back = " & FormatDatetime(iso.toDatetime(x))
	WScript.Echo "    Should be TRUE = " & CStr(iso.isComplete(x))
	WScript.Echo "   Should be FALSE = " & CStr(iso.isValid(x & "HSN"))
	WScript.Echo "  Adjusted to Zulu = " & iso.AdjustedToZ(x)
	WScript.Echo "     YYYY is valid = " & iso.isValid("2006")
	WScript.Echo "  YYYY-MM is valid = " & iso.isValid("2006-01")
	WScript.Echo "Date only is valid = " & iso.isValid("2006-01-01")
	WScript.Echo "   Should be FALSE = " & iso.isValid("2006-01-aa")
	testdate1 = "2006-04-01T01:01:01Z"
	testdate2 = "2006-04-01T01:01:01+00:00"
	testdate3 = "2006-03-31T21:01:01-04:00"
	WScript.Echo "  Adjusted to Zulu = " & iso.AdjustedToZ(testdate1)
	WScript.Echo "  Adjusted to Zulu = " & iso.AdjustedToZ(testdate2)
	WScript.Echo "  Adjusted to Zulu = " & iso.AdjustedToZ(testdate3)
	WScript.Echo "Compare " & testdate1 & " / " & testdate2 & " (0) = " & CStr(iso.Compare(testdate1,testdate2))
	WScript.Echo "Compare " & testdate2 & " / " & testdate3 & " (0) = " & CStr(iso.Compare(testdate2,testdate3))
	WScript.Echo "   Fractional time = " & iso.FractionalSeconds("2006-04-03T12:31:42.445Z")

	On Error Resume Next
	Err.Clear
	WScript.Echo " Duff date extract = " & iso.toDate("99")
	If Err.Number <> 0 Then 
		Wscript.Echo """" & Err.Source & """ returned error " & err.number & vbCrLf & vbTab & err.description
	End If
	
	
End Sub

TestHarness