' this is kinda long, but I had it laying around
' it converts just about anything to milliseconds, the
' units of an event timer.
Const c_SecondsInMinute As Integer = 60
Const c_SecondsInHour As Integer = c_SecondsInMinute * 60
Const c_SecondsInDay As Long = c_SecondsInHour * 24&
Const c_SecondsInWeek As Long = c_SecondsInDay * 7
Const c_SecondsInMonth As Double = c_SecondsInDay * 30#
Const c_SecondsInYear As Double = c_SecondsInDay * 365#
Public Function IsComma(CharValue As Integer) As Boolean
IsComma = (CharValue = Asc(","
)
End Function
Public Function IsBlank(CharValue As Integer) As Boolean
IsBlank = (CharValue = Asc(" "
)
End Function
Public Function IsDigit(CharValue As Integer) As Boolean
IsDigit = (CharValue >= Asc("0"
And CharValue <= Asc("9"
)
End Function
Public Function IsMinus(CharValue As Integer) As Boolean
IsMinus = (CharValue = Asc("-"
)
End Function
Public Function IsDot(CharValue As Integer) As Boolean
IsDot = (CharValue = Asc("."
)
End Function
Public Function IsNumeric(CharValue As Integer) As Boolean
IsNumeric = (IsDigit(CharValue) Or IsDot(CharValue) Or IsMinus(CharValue))
End Function
Function ConvertTextToMilliseconds(IntervalValue As String, RetVal As Double, Optional FractionOfDayAllowed As Boolean = True) As Boolean
ConvertTextToMilliseconds = False
Const c_MyName As String = "ConvertTextToMilliseconds"
On Error GoTo ConvertTextToMillisecondsError
IntervalValue = Trim(IntervalValue)
RetVal = 0
Dim Position As Integer
Position = 1
Dim StrLen As Integer
StrLen = Len(IntervalValue)
Dim HadNumber As Boolean
HadNumber = False
Dim NumericText As String
NumericText = ""
Dim HadUnits As Boolean
HadUnits = False
Dim UnitsText As String
UnitsText = ""
ConvertTextToMilliseconds = True
Do While Position <= StrLen
Do While Position <= StrLen
Dim CurChar As String
Dim CharValue As Integer
Do While Position <= StrLen
CurChar = Mid(IntervalValue, Position, 1)
CharValue = Asc(CurChar)
If Not (IsBlank(CharValue) Or IsComma(CharValue)) Then Exit Do
Position = Position + 1
Loop
If IsNumeric(CharValue) Then
Do While Position <= StrLen
CurChar = Mid(IntervalValue, Position, 1)
CharValue = Asc(CurChar)
If Not IsNumeric(CharValue) Then Exit Do
Position = Position + 1
NumericText = NumericText & CurChar
Loop
NumericText = Trim(NumericText)
If Len(UnitsText) > 0 Then Exit Do
Else
Do While Position <= StrLen
CurChar = Mid(IntervalValue, Position, 1)
CharValue = Asc(CurChar)
If IsDigit(CharValue) Or IsMinus(CharValue) Or IsBlank(CharValue) Or IsComma(CharValue) Then Exit Do
Position = Position + 1
UnitsText = UnitsText & CurChar
HadUnits = True
Loop
UnitsText = Trim(UnitsText)
If Len(NumericText) > 0 Then Exit Do
End If
Loop
If Len(NumericText) > 0 Then
If Not FractionOfDayAllowed And Left(UnitsText, 1) = "m" Then UnitsText = "mo"
Dim Multiplier As Double
If Len(UnitsText) = 0 Then
If FractionOfDayAllowed Then
UnitsText = "s"
Else
UnitsText = "d"
End If
End If
Select Case UnitsText
Case "years", "yrs.", "yrs", "yr.", "yr", "y"
Multiplier = c_SecondsInYear * 1000#
Case "months", "month", "mnths", "mons.", "mons", "mos.", "mon.", "mos", "mon", "mo.", "mos.", "mo"
Multiplier = c_SecondsInMonth * 1000#
Case "days", "day", "dys.", "dys", "dy.", "dy", "d.", "d"
Multiplier = c_SecondsInDay * 1000#
Case "weeks", "week", "wks.", "wks", "wk.", "wk", "w.", "w"
Multiplier = c_SecondsInWeek * 1000#
Case "hours", "hrs.", "hrs", "hr.", "hr", "h"
If Not FractionOfDayAllowed Then ConvertTextToMilliseconds = False
Multiplier = c_SecondsInHour * 1000#
Case "minutes", "minute", "mins.", "min.", "mins", "min", "m"
If Not FractionOfDayAllowed Then ConvertTextToMilliseconds = False
Multiplier = c_SecondsInMinute * 1000#
Case "seconds", "second", "secs.", "secs", "sec.", "sec", "s"
If Not FractionOfDayAllowed Then ConvertTextToMilliseconds = False
Multiplier = 1000#
Case "milliseconds", "millisecond", "msec.", "msec", "ms.", "ms"
If Not FractionOfDayAllowed Then ConvertTextToMilliseconds = False
Multiplier = 1#
Case Else
ConvertTextToMilliseconds = False
End Select
RetVal = RetVal + Multiplier * CDbl(NumericText)
Else
If Len(UnitsText) = 0 Then
ConvertTextToMilliseconds = False
End If
Exit Do
End If
NumericText = ""
UnitsText = ""
Loop
ConvertTextToMillisecondsExit:
Exit Function
ConvertTextToMillisecondsError:
MsgBox "Error in " & c_MyName & ": " & Err.Number & ", " & Err.Description
Resume ConvertTextToMillisecondsExit
End Function
Function ConvertTextToDays(IntervalValue As String, RetVal As Double) As Boolean
Dim CovertedOK As Boolean
CovertedOK = ConvertTextToMilliseconds(IntervalValue, RetVal, False)
If CovertedOK Then
RetVal = RetVal / (c_SecondsInDay * 1000#)
End If
ConvertTextToDays = CovertedOK
End Function
Function TestMe()
Dim RetVal As Double
ConvertTextToMilliseconds "5 m 37 s", RetVal, False
Debug.Print RetVal
End Function
