Attribute VB_Name = "modVBFns"
Option Explicit

Const NonTruncChar = " &+-.0123456789ABCDEFHOabcdefho"
Const ValidNumChar = "&+-.0123456789ABCDEFHOabcdefho"
Const ValidHexChar = "&0123456789ABCDEFHabcdefh"
Const HexDigits = "0123456789ABCDEFabcdef"
Const ValidOctChar = "&01234567Oo"
Const OctDigits = "01234567"
Const ValidDecChar = "+-.0123456789"
Const DecDigits = "0123456789"

Declare Function PeekMessagePlot Lib "coredll.dll" Alias "PeekMessageW" (ByVal Msg As String, ByVal hwnd As Long, ByVal wMsgFilterMin As Integer, ByVal wMsgFilterMax As Integer, ByVal wRemoveMsg As Integer) As Boolean
Declare Function TranslateMessagePlot Lib "coredll.dll" Alias "TranslateMessage" (ByVal Msg As String) As Boolean
Declare Function DispatchMessagePlot Lib "coredll.dll" Alias "DispatchMessageW" (ByVal Msg As String) As Boolean
Declare Sub Sleep Lib "coredll" (ByVal dwMilliseconds As Long)

Private Sub CEDoEvents()
    Dim wMsg As String
    Dim PmRemove As Integer
    
    wMsg = String(18, Chr(0))
    PmRemove = 1
    If PeekMessagePlot(wMsg, 0, 0, 0, PmRemove) Then
        Call TranslateMessagePlot(wMsg)
        Call DispatchMessagePlot(wMsg)
    End If
End Sub

'returns 0 if not octal or valid strlen
Private Function isDec(strVal As String) As Long
    Dim idxChar As Long
    Dim strStr As String
    Dim strChar As String
    Dim isStarted As Boolean
    Dim DecPntFnd As Boolean
    Dim HasSign As Boolean
    
    isDec = 0
    isStarted = False
    DecPntFnd = False
    HasSign = False
    
    strChar = Left(strVal, 1)
    If ((strChar = "+") Or (strChar = "-")) Then
        isStarted = True
        HasSign = True
    ElseIf (strChar = ".") Then
        DecPntFnd = True
        isStarted = True
    ElseIf (InStr(1, DecDigits, strChar) > 0) Then
        isStarted = True
    End If
    If (Not isStarted) Then Exit Function    'not valid char found
    isDec = 1
    For idxChar = 2 To Len(strVal)
        strChar = Mid(strVal, idxChar, 1)
        If (InStr(1, DecDigits, strChar) > 0) Then
            isDec = idxChar
        ElseIf ((strChar = ".") And (Not DecPntFnd)) Then
            isDec = idxChar
            DecPntFnd = True
        Else
            Exit For
        End If
    Next
    If ((DecPntFnd Or HasSign) And (isDec = 1)) Then isDec = 0
End Function

'returns 0 if not hex or valid strlen
Private Function isHex(strVal As String) As Long
    Dim idxChar As Long
    Dim strStr As String
    isHex = 0
    If (UCase(Left(strVal, 2)) = "&H") Then
        For idxChar = 3 To Len(strVal)
            If (InStr(1, HexDigits, Mid(strVal, idxChar, 1), vbTextCompare) > 0) Then
                isHex = idxChar
            Else
                Exit For
            End If
        Next
    End If
End Function

'returns 0 if not octal or valid strlen
Private Function isOctal(strVal As String) As Long
    Dim idxChar As Long
    Dim strStr As String
    isOctal = 0
    If (UCase(Left(strVal, 2)) = "&O") Then
            For idxChar = 3 To Len(strVal)
            If (InStr(1, OctDigits, Mid(strVal, idxChar, 1), vbTextCompare) > 0) Then
                isOctal = idxChar
            Else
                Exit For
            End If
        Next
    End If
End Function

Private Function RemoveSpaces(strVal As String) As String
    Dim idxChar As Long
    Dim strStr As String
    strStr = ""
    For idxChar = 1 To Len(strVal)          'truncate starting at first invalid char
        If (Mid(strVal, idxChar, 1) <> " ") Then
            strStr = strStr & Mid(strVal, idxChar, 1)
        End If
    Next
    RemoveSpaces = strStr
End Function

'truncate characters starting with first non valid char except space
Private Function TruncValStr(strVal As String) As String
    Dim idxChar As Long
    Dim strChar As String
    Dim strTemp As String
    Dim strNum As String
    strNum = ""
    For idxChar = 1 To Len(strVal)          'truncate starting at first invalid char
        strChar = Mid(strVal, idxChar, 1)
        If (InStr(1, NonTruncChar, strChar, vbTextCompare) > 0) Then
            strNum = strNum & strChar
        Else
            Exit For
        End If
    Next
    If (Len(strNum) = 0) Then           'exit if no numbers present
        TruncValStr = "0"
        Exit Function
    Else
        strTemp = strNum
        strNum = ""
    End If
    strNum = RemoveSpaces(strTemp)      'remove whitespace
    If (Len(strNum) = 0) Then           'exit if string was only whitespace
        TruncValStr = "0"
        Exit Function
    Else
        strTemp = strNum
        strNum = ""
    End If
    If (IsNumeric(strTemp)) Then        'exit if number found
        TruncValStr = strTemp
        Exit Function
    End If
    'more processing is still needed
    If CBool(isHex(strTemp)) Then
        strNum = Left(strTemp, isHex(strTemp))
        If (Not IsNumeric(strNum)) Then
            strNum = "0"
        End If
        TruncValStr = strNum
        Exit Function
    ElseIf CBool(isOctal(strTemp)) Then
        strNum = Left(strTemp, isOctal(strTemp))
        If (Not IsNumeric(strNum)) Then
            strNum = "0"
        End If
        TruncValStr = strNum
        Exit Function
    ElseIf CBool(isDec(strTemp)) Then
        strNum = Left(strTemp, isDec(strTemp))
        If (Not IsNumeric(strNum)) Then
            strNum = "0"
        End If
        TruncValStr = strNum
        Exit Function
    Else
        TruncValStr = "0"
        Exit Function
    End If
End Function

Public Function Val(ByRef varVal As Variant) As Variant
'Private Function Val(ByRef varVal As Variant) As Variant
    Dim strTemp As String
    Dim strNum As String

    If IsEmpty(varVal) Then
        Val = 0
        Exit Function
    End If
    If IsNull(varVal) Then
        Val = 0
        Exit Function
    End If
    If IsNumeric(varVal) Then
        Val = varVal
    ElseIf (TypeName(varVal) = "String") Then
        If (Len(varVal) = 0) Then   'empty string
            Val = 0
            Exit Function
        End If
        Val = TruncValStr(CStr(varVal))
    Else
        Val = 0
    End If

End Function

'Public Function ValVB(ByRef varVal As Variant) As Variant
'    ValVB = Val(varVal)
'End Function

Public Function IIf(varTest As Variant, varTrue As Variant, varFalse As Variant) As Variant
    If CBool(varTest) Then
        IIf = varTrue
    Else
        IIf = varFalse
    End If
End Function

Public Function QBColor(vbColor As Variant)
    Select Case vbColor
        Case 0   'Black
            QBColor = &H0&
        Case 1   'Blue
            QBColor = &H800000
        Case 2   'Green
            QBColor = &H8000&
        Case 3   'Cyan
            QBColor = &H808000
        Case 4   'Red
            QBColor = &H80&
        Case 5   'Magenta
            QBColor = &H800080
        Case 6   'Yellow
            QBColor = &H8080&
        Case 7   'White
            QBColor = &HC0C0C0
        Case 8   'Gray
            QBColor = &H808080
        Case 9   'Light Blue
            QBColor = &HFF0000
        Case 10  'Light Green
            QBColor = &HFF00&
        Case 11  'Light Cyan
            QBColor = &HFFFF00
        Case 12  'Light Red
            QBColor = &HFF&
        Case 13  'Light Magenta
            QBColor = &HFF00FF
        Case 14  'Light Yellow
            QBColor = &HFFFF&
        Case 15  'Bright White
            QBColor = &HFFFFFF
        Case Else
    End Select
End Function

Public Function ZeroPad(varNumber As Variant, NumDigits As Integer) As String
    Dim lLen As Integer
    Dim ZerosNeeded As Integer
    Dim strNum As String
    On Error Resume Next
    strNum = CStr(varNumber)
    lLen = Len(strNum)
    If ((NumDigits <= 0) Or (NumDigits > 10)) Then
        ZeroPad = strNum
    ElseIf (NumDigits <= lLen) Then
        ZeroPad = strNum
    ElseIf (NumDigits > lLen) Then
        ZerosNeeded = NumDigits - lLen
        ZeroPad = String(ZerosNeeded, "0") & strNum
    Else        'unknown error
        ZeroPad = strNum
    End If
End Function

Public Function CreateDTS() As String
    Dim varNow As Variant
    Dim strYear As String
    Dim strMonth As String
    Dim strDay As String
    Dim strHour As String
    Dim strMinute As String
    Dim strSecond As String
    Dim strDTS As String
    
    varNow = Now
    strYear = ZeroPad(Year(varNow), 4)
    strMonth = ZeroPad(Month(varNow), 2)
    strDay = ZeroPad(Day(varNow), 2)
    strHour = ZeroPad(Hour(varNow), 2)
    strMinute = ZeroPad(Minute(varNow), 2)
    strSecond = ZeroPad(Second(varNow), 2)
    strDTS = strYear & strMonth & strDay & "_" & strHour & strMinute & strSecond
    CreateDTS = strDTS
End Function