SHARE
TWEET

Compare two variants with VBA

a guest Jan 24th, 2020 79 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Explicit
  2.  
  3. Class CompareTool
  4.     Dim TypeNameDict
  5.     Dim MyType_Simple
  6.     Dim MyType_Date
  7.     Dim MyType_String
  8.     Dim MyType_Wierd
  9.     Dim MyType_Error
  10.     Dim MyType_Empty
  11.     Dim MyType_Null
  12.     Dim MyType_Object
  13.     Dim MyType_Unknown
  14.     Dim MyType_Nothing
  15.  
  16.     Private Sub Class_Initialize()
  17.         Set TypeNameDict = CreateObject("Scripting.Dictionary")    
  18.         MyType_Simple = 1
  19.         MyType_Date = 2
  20.         MyType_String = 3
  21.         MyType_Wierd = 4
  22.         MyType_Error = 5
  23.         MyType_Empty = 6
  24.         MyType_Null = 7
  25.         MyType_Object = 8
  26.         MyType_Unknown = 9
  27.         MyType_Nothing = 10
  28.         TypeNameDict("Byte") = MyType_Simple
  29.         TypeNameDict("Integer") = MyType_Simple
  30.         TypeNameDict("Long") = MyType_Simple
  31.         TypeNameDict("Single") = MyType_Simple
  32.         TypeNameDict("Double") = MyType_Simple
  33.         TypeNameDict("Currency") = MyType_Simple
  34.         TypeNameDict("Decimal") = MyType_Simple
  35.         TypeNameDict("Date") = MyType_Date
  36.         TypeNameDict("Boolean") = MyType_Simple
  37.         TypeNameDict("String") = MyType_String
  38.         TypeNameDict("Error") = MyType_Error
  39.         TypeNameDict("Empty") = MyType_Empty
  40.         TypeNameDict("Null") = MyType_Null
  41.         TypeNameDict("Object") = MyType_Object
  42.         TypeNameDict("Unknown") = MyType_Unknown
  43.         TypeNameDict("Nothing") = MyType_Nothing
  44.     End Sub ' Class_Initialize
  45.  
  46.     Private Sub Class_Terminate()
  47.         Set TypeNameDict = Nothing
  48.     End Sub ' Class_Terminate
  49.    
  50.     Private Function StdCompare(Var1, Var2)
  51.         If Var1 > Var2 Then
  52.             StdCompare = 1
  53.         ElseIf Var1 < Var2 Then
  54.             StdCompare = -1
  55.         Else
  56.             StdCompare = 0
  57.         End If
  58.     End Function ' StdCompare
  59.    
  60.     ' Compare two Variants that they are not an arrays or objects.
  61.    Public Function CompareVariants(Var1, Var2) ' CompareVariants(Variant, Variant) As Long
  62.        Dim T1, T2
  63.         Dim D1, D2
  64.        
  65.         ' Examine
  66.        On Error Resume Next
  67.         T1 = TypeName(Var1)
  68.         If Err.Number <> 0 Then
  69.             Err.Clear
  70.             CompareVariants = -1
  71.         End If
  72.         T2 = TypeName(Var2)
  73.         If Err.Number <> 0 Then
  74.             Err.Clear
  75.             CompareVariants = 1
  76.         End If
  77.         D1 = TypeNameDict(T1)
  78.         If Err.Number <> 0 Then
  79.             Err.Clear
  80.             CompareVariants = -1
  81.         End If    
  82.         D2 = TypeNameDict(T2)
  83.         If Err.Number <> 0 Then
  84.             Err.Clear
  85.             CompareVariants = 1
  86.         End If
  87.         On Error Goto 0
  88.         ' Compare
  89.        If D1 >= MyType_Wierd Or D2 >= MyType_Wierd Then
  90.             ' Sort weird type in one pile and normal types in another.
  91.            If D1 < MyType_Wierd Then
  92.                 CompareVariants = 1
  93.             ElseIf D2 < MyType_Wierd Then
  94.                 CompareVariants = -1
  95.             Else
  96.                 ' Sort weird types by typename instead of by value.            
  97.                CompareVariants = StrComp(T1, T2, 1)
  98.             End If
  99.         ElseIf D1 = MyType_Date Or D2 = MyType_Date Then
  100.             If D1 = MyType_String Then
  101.                 CompareVariants = StdCompare(DateValue(Var1), Var2)
  102.             ElseIf D2 = MyType_String Then
  103.                 CompareVariants = StdCompare(DateValue(Var2), Var1)
  104.             Else
  105.                 CompareVariants = StdCompare(Var1, Var2)
  106.             End If
  107.         ElseIf D1 = MyType_String Or D2 = MyType_String Then
  108.             CompareVariants = StrComp(Var1, Var2, 1)
  109.         Else
  110.             CompareVariants = StdCompare(Var1, Var2)
  111.         End If
  112.     End Function ' CompareVariants
  113.  
  114.     Public Sub DebugCompare(Var1, Var2)
  115.         WScript.Echo "Compare(" & Var1 & ", " & Var2 & ") == " & CompareVariants(Var1, Var2)
  116.     End Sub ' DebugCompare
  117.  
  118.    
  119. End Class ' CompareTool
  120.  
  121. Sub TestMe()
  122.     Dim tool, mydate
  123.     mydate = Now
  124.     set tool = new CompareTool
  125.     WScript.Echo "-- numbers"
  126.     tool.DebugCompare 42, 42
  127.     tool.DebugCompare 1, 2
  128.     tool.DebugCompare 2, 1
  129.     tool.DebugCompare 2.22, 1.11
  130.     tool.DebugCompare 1.11, 2.22
  131.     WScript.Echo "-- date vs string"
  132.     tool.DebugCompare mydate, "2021-01-02"
  133.     tool.DebugCompare mydate, "2019-01-02"
  134.     tool.DebugCompare "2021-01-02", mydate
  135.     tool.DebugCompare "2019-01-02", mydate
  136.     WScript.Echo "-- dates"
  137.     tool.DebugCompare mydate, mydate
  138.     tool.DebugCompare mydate, DateValue("2021-01-02")
  139.     tool.DebugCompare mydate, DateValue("2019-01-02")
  140.     tool.DebugCompare DateValue("2021-01-02"), mydate
  141.     tool.DebugCompare DateValue("2019-01-02"), mydate
  142.     WScript.Echo "-- strings"
  143.     tool.DebugCompare "Bob", "Bob"
  144.     tool.DebugCompare "Bob", "Alice"
  145.     tool.DebugCompare "Alice", "Bob"
  146.     tool.DebugCompare "Alice", "Carl"
  147.     tool.DebugCompare "Carl", "Alice"
  148.     tool.DebugCompare "Alice", "#Carl"
  149.     tool.DebugCompare "#Carl", "Alice"
  150.     WScript.Echo "-- misc"
  151.     tool.DebugCompare "Carl", Empty
  152.     tool.DebugCompare Empty, "Carl"
  153. End Sub ' TestMe
  154.  
  155. TestMe
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top