VBCommons/utility/ex_VBA.bas

Attribute VB_Name = "ex_VBA"
' ======== VBA Extensions for objects and messaging ========
' Shared module version: 20220623
' Tested in: TestCommons
' Depends on:
' Required reference: Scripting
Option Private Module
Option Explicit

Public Const VBA_INVALID_SIZE = -1

Public Enum SystemErrors
  SYS_ERR_TYPE_MISMATCH = 13
  SYS_ERR_INVALID_OPERATION = 17
End Enum

Public Function ArraySize(target As Variant, Optional nDimension% = 1) As Long
  On Error GoTo INVALID_SIZE
  
  ArraySize = UBound(target, nDimension) - LBound(target, nDimension) + 1
  Exit Function

INVALID_SIZE:
  ArraySize = VBA_INVALID_SIZE
End Function

' Returns dictionary of indicies of first occurence for every element in array @aSource
' Note: duplicate elements are ignored
Public Function ArrayToIndex(iSource As Variant) As Scripting.Dictionary
  If Not IsArrayAllocated(iSource) Then _
    Exit Function
    
  Dim indicies As New Scripting.Dictionary
  Dim vValue As Variant
  Dim nIndex&: nIndex = LBound(iSource, 1)
  For Each vValue In iSource
    If Not indicies.Exists(vValue) Then _
      Call indicies.Add(vValue, nIndex)
    nIndex = nIndex + 1
  Next vValue
  Set ArrayToIndex = indicies
End Function

Public Function IsArrayAllocated(target As Variant) As Boolean
  IsArrayAllocated = False
  If Not IsArray(target) Then _
    Exit Function
    
  On Error Resume Next
  Dim nSize&: nSize = UBound(target, 1)
  If Err.Number <> 0 Then
    Call Err.Clear
    Exit Function
  End If
  On Error GoTo 0
  
  IsArrayAllocated = LBound(target) <= UBound(target)
End Function

Public Function FixForwardedParams(params As Variant) As Variant
  FixForwardedParams = params
  If IsArrayAllocated(params) Then _
    If VBA.IsArray(params(0)) Then _
      If ArraySize(params, 1) = 1 Then _
        FixForwardedParams = params(0)
End Function

Public Function CColl(ParamArray params() As Variant) As Collection
  Set CColl = New Collection
  Dim val As Variant
  For Each val In params
    Call CColl.Add(val)
  Next val
End Function

Public Function CSet(ParamArray params() As Variant) As Scripting.Dictionary
  Set CSet = New Scripting.Dictionary
  Dim vValue As Variant
  For Each vValue In params
    CSet.Item(vValue) = 0
  Next vValue
End Function

Public Function CDict(ParamArray params() As Variant) As Scripting.Dictionary
  If UBound(params) > 0 Then _
    If UBound(params) Mod 2 <> 1 Then _
      Call Err.Raise(vbObjectError, Description:="Dictionary params should be key and value pairs")
  
  Set CDict = New Scripting.Dictionary
  If UBound(params) <= 0 Then _
    Exit Function
  Dim nItem&
  For nItem = 0 To UBound(params) / 2 Step 1
    Call CDict.Add(params(2 * nItem), params(2 * nItem + 1))
  Next nItem
End Function

Public Function CollectionToDictionary(iSource As Collection) As Scripting.Dictionary
  Dim iDict As New Scripting.Dictionary
  Dim nIndex&: nIndex = 1
  Dim vValue As Variant
  For Each vValue In iSource
    If Not iDict.Exists(vValue) Then _
      Call iDict.Add(vValue, nIndex)
    nIndex = nIndex + 1
  Next vValue
  Set CollectionToDictionary = iDict
End Function

' Add unique (key, value) pairs from Source to Destination without deep copy
Public Function DictionaryAbsorbShallow(iDestination As Scripting.Dictionary, iSource As Scripting.Dictionary)
  Dim aKey As Variant
  For Each aKey In iSource
    If Not iDestination.Exists(aKey) Then _
      Call iDestination.Add(aKey, iSource(aKey))
  Next aKey
End Function

' Convert paramarray into unique list, where value equals 1-based index into input array
' Duplicates are skipped
Public Function UniqueList(ParamArray params() As Variant) As Scripting.Dictionary
  Set UniqueList = New Scripting.Dictionary
  Dim vValue As Variant
  Dim nIndex&: nIndex = 1
  For Each vValue In params
    If Not UniqueList.Exists(vValue) Then _
      Call UniqueList.Add(vValue, nIndex)
    nIndex = nIndex + 1
  Next vValue
End Function

' Compare two floats / integers and return difference or 0 if Precision is not met
' Note: positive precision indicates number of positions after decimal
'       while negative precision indicates positions before decimal
Public Function CompareApproximate(val1 As Variant, val2 As Variant, nDecimalPrecision&) As Double
  CompareApproximate = val1 - val2
  If CompareApproximate = 0 Then _
    Exit Function
  If VBA.Log(VBA.Abs(CompareApproximate)) / VBA.Log(10) < -nDecimalPrecision Then _
    CompareApproximate = 0
End Function

' Compate two Variants
' Integer values will resolve into their difference
' Other types will return 0 if objects are equal and unspecified number otherwise
' Object type will try to call Compare() function if it is available for the type
'   otherwise objects will by compared using ObjPtr()
' If there is no way to compare values the Error SYS_ERR_INVALID_OPERATION will be raised
' Warning: multidimensional arrays are not supported!
Public Function CompareDeep(val1 As Variant, val2 As Variant) As Double
  If TryMinus(val1, val2, CompareDeep) Then
    Exit Function
  ElseIf TryEquality(val1, val2) Then
    CompareDeep = 0
    Exit Function
  ElseIf TryInequality(val1, val2) Then
    CompareDeep = 1
    Exit Function
  End If
  
  Dim vType As VBA.VbVarType: vType = VBA.VarType(val1)
  If vType <> VBA.VarType(val2) Then
    GoTo UNCOMPARABLE
  ElseIf vType >= vbArray And vType <= vbArray + vbByte Then
    CompareDeep = CompareDeepArray(val1, val2)
    Exit Function
  End If
  
  Dim sType$: sType = VBA.TypeName(val1)
  If sType <> VBA.TypeName(val2) Then _
    GoTo UNCOMPARABLE
  
  On Error GoTo UNCOMPARABLE
  Select Case sType
    Case "Collection": CompareDeep = CompareDeepCollection(val1, val2)
    Case "Dictionary": CompareDeep = CompareDeepDictionary(val1, val2)
    Case Else: CompareDeep = CompareDeepObjects(val1, val2)
  End Select
  Exit Function
  
UNCOMPARABLE:
  Call Err.Raise(SYS_ERR_INVALID_OPERATION)
End Function

Public Function ExtractTimestamp(sLine$) As Double
  Dim sStamp$: sStamp = ExtractDatePrefix(sLine)
  If sStamp = vbNullString Then _
    Exit Function
    
  On Error GoTo INVALID_FORMAT
  ExtractTimestamp = DateValue(sStamp) + TimeValue(sStamp)
  Exit Function
  
INVALID_FORMAT:
  Call Err.Clear
  ExtractTimestamp = 0
End Function

Public Function TrimTimestamp(sLine$) As String
  TrimTimestamp = sLine
  Dim sStamp$: sStamp = ExtractDatePrefix(sLine)
  If sStamp = vbNullString Then _
    Exit Function
  If ExtractTimestamp(sStamp) = 0 Then _
    Exit Function
  
  If VBA.Len(sLine) > VBA.Len(sStamp) + 2 Then
    TrimTimestamp = VBA.Right(sLine, VBA.Len(sLine) - VBA.Len(sStamp) - 2)
  Else
    TrimTimestamp = vbNullString
  End If
End Function

Public Function CommonPrefixLength(sText1$, sText2$, Optional nMode As VbCompareMethod = vbBinaryCompare) As Long
  Dim nPrefixEnd&: nPrefixEnd = 0
  Dim nLen&: nLen = VBA.Len(sText1)
  nLen = IIf(nLen < VBA.Len(sText2), VBA.Len(sText2), nLen)
  Do While nPrefixEnd < nLen
    If VBA.StrComp(VBA.Mid(sText1, nPrefixEnd + 1, 1), _
                    VBA.Mid(sText2, nPrefixEnd + 1, 1), nMode) <> 0 Then _
      Exit Do
    nPrefixEnd = nPrefixEnd + 1
  Loop
  CommonPrefixLength = nPrefixEnd
End Function

' Formatting function
' Expected message format: "test {1} argument enumerating 1-based"
' Note: params array is 0-base enumerated
Public Function Fmt(sMsg$, ParamArray params() As Variant) As String
  Dim vValue As Variant
  Dim nIndex&: nIndex = 1
  Fmt = sMsg
  
  Dim unwrapped As Variant: unwrapped = params
  unwrapped = FixForwardedParams(unwrapped)
  For Each vValue In unwrapped
    Fmt = VBA.Replace(Fmt, "{" & nIndex & "}", PrettyPrint(vValue))
    nIndex = nIndex + 1
  Next vValue
End Function

' Warning: multidimensional arrays are not supported!
Public Function PrettyPrint(vValue As Variant, Optional nIndent& = 0) As String
  Select Case VBA.VarType(vValue)
    Case VBA.vbEmpty: PrettyPrint = "[Empty]"
    Case VBA.vbNull: PrettyPrint = "[Null]"
    Case VBA.vbString: PrettyPrint = vValue
    Case VBA.vbArray To VBA.vbArray + VBA.vbByte: PrettyPrint = PrintArray(vValue, nIndent)
    Case VBA.vbObject
      If vValue Is Nothing Then
        PrettyPrint = "[Nothing]"
      ElseIf VBA.TypeName(vValue) = "Collection" Then
        PrettyPrint = PrintCollection(vValue, nIndent)
      ElseIf VBA.TypeName(vValue) = "Dictionary" Then
        PrettyPrint = PrintDictionary(vValue, nIndent)
      Else
        PrettyPrint = PrintCustomObject(vValue, nIndent)
      End If
    Case Else: PrettyPrint = Var2Str(vValue)
  End Select
End Function

Public Function Indent(Optional nIndent&)
  Indent = VBA.String$(nIndent, "  ")
End Function

' ==========
Private Function ExtractDatePrefix(sLine$) As String
  If sLine = vbNullString Then _
    Exit Function
  Dim nEnd&: nEnd = VBA.InStr(1, sLine, " ")
  If nEnd <> 0 Then _
    nEnd = VBA.InStr(nEnd + 1, sLine, " ")
  If nEnd = 0 Then
    nEnd = VBA.Len(sLine)
  Else
    nEnd = nEnd - 1
  End If
  
  If VBA.Mid(sLine, nEnd, 1) = ":" Then _
    nEnd = nEnd - 1
  ExtractDatePrefix = VBA.Left(sLine, nEnd)
End Function

Private Function Var2Str(target As Variant) As String
  On Error GoTo CANNOT_CONVERT
  Var2Str = CStr(target)
  Exit Function
  
CANNOT_CONVERT:
  Var2Str = "[T" & VarType(target) & "] "
  On Error GoTo NON_STRING
  If target Is Nothing Then
    Var2Str = Var2Str & "Nothing"
    Exit Function
  End If

NON_STRING:
  Var2Str = Var2Str & "non-stringable"
End Function

Private Function TryEquality(val1 As Variant, val2 As Variant) As Boolean
  On Error Resume Next
  TryEquality = val1 = val2
End Function

Private Function TryInequality(val1 As Variant, val2 As Variant) As Boolean
  On Error Resume Next
  TryInequality = val1 <> val2
End Function

Private Function TryMinus(val1 As Variant, val2 As Variant, ByRef dDiff As Double) As Boolean
  On Error GoTo CANNOT_DIFF
  
  dDiff = val1 - val2
  TryMinus = True
  Exit Function
  
CANNOT_DIFF:
  TryMinus = False
End Function

Private Function CompareDeepArray(val1 As Variant, val2 As Variant) As Double
  If Not IsArrayAllocated(val1) Then
    CompareDeepArray = IIf(IsArrayAllocated(val2), 1, 0)
    Exit Function
  End If
  
  CompareDeepArray = UBound(val1) - UBound(val2)
  If CompareDeepArray <> 0 Then _
    Exit Function
  CompareDeepArray = LBound(val1) - LBound(val2)
  If CompareDeepArray <> 0 Then _
    Exit Function
  
  On Error GoTo UNCOMPARABLE_ELEMENTS
  Dim nItem&
  For nItem = LBound(val1) To UBound(val2) Step 1
    If CompareDeep(val1(nItem), val2(nItem)) <> 0 Then
      CompareDeepArray = 1
      Exit Function
    End If
  Next nItem
  
  CompareDeepArray = 0
  Exit Function
  
UNCOMPARABLE_ELEMENTS:
  CompareDeepArray = 1
End Function

Private Function CompareDeepCollection(val1 As Variant, val2 As Variant) As Double
  Dim nCount&: nCount = val1.Count
  CompareDeepCollection = nCount - val2.Count
  If CompareDeepCollection <> 0 Then _
    Exit Function
    
  On Error GoTo UNCOMPARABLE_ELEMENTS
  Dim nItem&
  For nItem = 1 To nCount Step 1
    If CompareDeep(val1(nItem), val2(nItem)) <> 0 Then
      CompareDeepCollection = 1
      Exit Function
    End If
  Next nItem
  
  CompareDeepCollection = 0
  Exit Function
  
UNCOMPARABLE_ELEMENTS:
  CompareDeepCollection = 1
End Function

Private Function CompareDeepDictionary(val1 As Variant, val2 As Variant) As Double
  Dim nCount&: nCount = val1.Count
  CompareDeepDictionary = nCount - val2.Count
  If CompareDeepDictionary <> 0 Then _
    Exit Function
    
  On Error GoTo UNCOMPARABLE_ELEMENTS
  Dim vKey As Variant
  For Each vKey In val1
    If Not val2.Exists(vKey) Then _
      GoTo UNCOMPARABLE_ELEMENTS
    If CompareDeep(val1(vKey), val2(vKey)) <> 0 Then
      CompareDeepDictionary = 1
      Exit Function
    End If
  Next vKey
  
  CompareDeepDictionary = 0
  Exit Function
  
UNCOMPARABLE_ELEMENTS:
  CompareDeepDictionary = 1
End Function

Public Function CompareDeepObjects(val1 As Variant, val2 As Variant) As Double
  On Error Resume Next
  CompareDeepObjects = val1.Compare(val2)
  If Err.Number = 0 Then _
    Exit Function
  Call Err.Clear
  CompareDeepObjects = IIf(ObjPtr(val1) = ObjPtr(val2), 0, 1)
End Function

Private Function PrintCollection(target As Variant, nIndent&) As String
  If target.Count = 0 Then
    PrintCollection = "$Collection []"
    Exit Function
  End If
  
  PrintCollection = "$Collection [" & vbNewLine
  Dim nItem&: nItem = 0
  Dim anItem As Variant
  For Each anItem In target
    nItem = nItem + 1
    PrintCollection = PrintCollection & _
      Indent(nIndent + 1) & PrettyPrint(anItem, nIndent + 1) & _
      IIf(nItem <> target.Count, ",", "") & vbNewLine
  Next anItem
  PrintCollection = PrintCollection & Indent(nIndent) & "]"
End Function

Private Function PrintDictionary(target As Variant, nIndent&) As String
  If target.Count = 0 Then
    PrintDictionary = "$Dictionary []"
    Exit Function
  End If
  
  PrintDictionary = "$Dictionary [" & vbNewLine
  Dim nItem&: nItem = 0
  Dim aKey As Variant
  For Each aKey In target
    nItem = nItem + 1
    PrintDictionary = PrintDictionary & _
      Indent(nIndent + 1) & aKey & ": " & _
      PrettyPrint(target(aKey), nIndent + 1) & _
      IIf(nItem <> target.Count, ",", "") & vbNewLine
  Next aKey
  PrintDictionary = PrintDictionary & Indent(nIndent) & "]"
End Function

Private Function PrintCustomObject(vValue As Variant, nIndent&) As String
  On Error GoTo PRINT_TYPE
  PrintCustomObject = vValue.ToString(nIndent)
  Exit Function
PRINT_TYPE:
  PrintCustomObject = "[" & VBA.TypeName(vValue) & "]"
End Function

Private Function PrintArray(target As Variant, nIndent&) As String
  If Not IsArrayAllocated(target) Then
    PrintArray = "$Array []"
    Exit Function
  End If
  
  PrintArray = "$Array [" & vbNewLine
  Dim nItem&
  Dim nLast&: nLast = UBound(target, 1)
  For nItem = LBound(target, 1) To nLast
    PrintArray = PrintArray & _
      Indent(nIndent + 1) & PrettyPrint(target(nItem), nIndent + 1) & _
      IIf(nItem <> nLast, ",", "") & vbNewLine
  Next nItem
  PrintArray = PrintArray & Indent(nIndent) & "]"
End Function