[VBA] compaire()

Eine Funktion zum Vergleichen. Klingt eigentlich unnötig. Doch vergleicht sie alles Mögliche. Arrays untereinander, Dictionaries, Null mit Empty etc.

Download udf_compaire.bas (V-1.0.1)

'Ein einfacher Vergleich 2er Werte
? compaire(1234, 1234.00)
True
 
'Dasselbe mit Typenprüfung. Der Erste Parameter ist ein Integer, der Zweite ein Double
? compaire(1234, 1234.00, cpVarTypeStrong)
False
 
'Dasselbe Spiel mit einem Vergleich 0 und Null
? compaire(Null, 0)
True
? compaire(Null, 0, cpVarTypeStrong)
False

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

Ich vergleiche mal die 2 folgenden Arrays miteinander
print_rm array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2)
<Variant()>  (
    [0] => <String> 1
    [1] => <String> 2
    [2] => <String> 2
    [3] => <Variant()>  (
        [0] => <String> 4
        [1] => <String> 5
    )
)
<Variant()>  (
    [0] => <Integer> 2
    [1] => <Integer> 1
    [2] => <Variant()>  (
        [0] => <Double> 5
        [1] => <Double> 4
    )
    [3] => <Integer> 2
)
 
'Normalverlgeich. Es wird Index und Value verglichen. Das ganze ohne Typenvergleich
? compaire(array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2))
False
 
'Nur ValueVergleich, immer noch ohne Typenvergleich
? compaire(array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2),cpArrayValuesOnly)
True
 
'Und jetzt mit Mit Typenvergleich
? compaire(array("1","2","2",array("4","5")), array(2,1,array(5.0,4.0),2), cpArrayValuesOnly+cpVarTypeStrong)
False

Für die folgenden Vergleich mit Dictionaries verwende ich die Funktion [VBA] cDict() um die Dictionaries zu erstellen
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

'Die Arrays:
print_rm cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1)
<Dictionary>  (
    [A] => <Integer> 1
    [B] => <Double> 2
)
<Dictionary>  (
    [B] => <Integer> 2
    [A] => <Integer> 1
)
 
'Erster Vergleich: Check ob beide dieselben Einträge mit denselben Werten beinhaltet
? compaire(cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1))
True
 
'Überprüft, ob die 2 Objekte dieselbe Instanz sind
? compaire(cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1), cpInstanceCompaire)
False
 
'Zusätzlich zu den Keys und Values auf den Values noch ein Typenvergleich
? compaire(cDict("A", 1, "B", 2.0) , cDict("B", 2, "A", 1), cpVarTypeStrong)
False

udf_compaire.bas

Attribute VB_Name = "udf_compaire"
'-------------------------------------------------------------------------------
'File         : udf_compaire.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/compaire
'Environment  : VBA 2010 +
'Version      : 1.0.1
'Name         : compaire
'Author       : Stefan Erb (ERS)
'History      : 12.09.2014 - ERS - Creation
'               16.09.2014 - ERS - Neue Version von cast()
'-------------------------------------------------------------------------------
Option Explicit
 
Public Enum cpComapireParams
    cpNone = 0
    cpVarTypeStrong = 2 ^ 0         'Datentype aus varType() muss ebenfalls übereinstimmen
    cpInstanceCompaire = 2 ^ 1      'Objekte nur auf Referenz prüfen. Gilt vor allem für Dictionaries
    cpArrayValuesOnly = 2 ^ 2       'Bei Arrayvergleich den Index ignorieren
End Enum
 
'/**
' * Vergleicht 2 Variaben
' * @param  Variant
' * @param  Variant
' * @return Boolean
' */
Public Function compaire(ByRef iVar1 As Variant, ByRef iVar2 As Variant, Optional ByVal iParams As cpComapireParams = cpNone) As Boolean
    Dim i As Integer, j As Integer, k As Integer
 
    'Typenvergleich bei Parameter cpVarTypeStrong durchführen
    If iParams And cpVarTypeStrong Then If Not (VarType(iVar1) = VarType(iVar2)) Then Exit Function
 
    'Null Vergleich
    If IsNull(iVar1) Or IsNull(iVar2) Then
        compaire = IsNull(cast(vbNull, iVar1)) And IsNull(cast(vbNull, iVar2))
    'in Array vergleichen
    ElseIf (iParams And cpArrayValuesOnly) And IsArray(iVar1) And IsArray(iVar2) Then
        If Not UBound(iVar1) - LBound(iVar1) = UBound(iVar2) - LBound(iVar2) Then Exit Function
        Dim check() As Boolean: ReDim check(LBound(iVar2) To UBound(iVar2))
        For i = LBound(iVar1) To UBound(iVar1)
            For j = LBound(iVar2) To UBound(iVar2)
                If Not check(j) Then
                    compaire = compaire(iVar1(i), iVar2(j), iParams)
                    If compaire Then
                        check(j) = True
                        Exit For
                    End If
                End If
            Next j
            If Not compaire Then Exit Function
        Next i
 
    ElseIf IsArray(iVar1) And IsArray(iVar2) Then
        If Not LBound(iVar1) = LBound(iVar2) And UBound(iVar1) = UBound(iVar2) Then Exit Function
        For i = LBound(iVar1) To UBound(iVar1)
            compaire = compaire(iVar1(i), iVar2(i), iParams)
            If Not compaire Then Exit Function
        Next i
    'in Array suchen
    'Objekt-Vergleich
    ElseIf IsObject(iVar1) And IsObject(iVar2) Then
        'Dictionary kann über den Key verglichen werden
        If TypeName(iVar1) = "Dictionary" And TypeName(iVar2) = "Dictionary" And Not CBool(iParams And cpInstanceCompaire) Then
            If iVar1.count = iVar2.count Then
                Dim keys As Variant: keys = iVar1.keys
                For k = 0 To iVar1.count - 1
                    If Not iVar2.exists(keys(k)) Then Exit Function
                    If Not compaire(iVar1(keys(k)), iVar2(keys(k)), iParams) Then Exit Function
                Next k
                compaire = True
            End If
        'Objekte auf Referenz prüfen
        Else
            compaire = (iVar1 Is iVar2)
        End If
    'Value-Vergleich
    ElseIf Not IsObject(iVar1) And Not IsObject(iVar2) And Not IsArray(iVar1) And Not IsArray(iVar2) Then
        compaire = (iVar1 = cast(VarType(iVar1), iVar2))
    End If
End Function
 
'/**
' * Wandelt einen String wenn möglich in das angegebene Format um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cast
' * V1.0.1
' * @param  VbVarType
' * @param  Variant
' * @param  Boolean     : Bei True wird ein Fehler greworfen, wenn der cast1() nichtr durchfürbar ist. Ansonsten wir der Eingabewert zurückgegeben
' * @return Variant
' */
Private Function cast(ByVal iType As VbVarType, ByVal iVar As Variant, Optional ByVal iStrong As Boolean = False) As Variant
On Error GoTo Err_Handler
 
    cast = iVar
    Select Case iType
        Case vbNull, vbEmpty
                            If Not (iVar = Empty Or IsNull(iVar)) Then Err.Raise 13         'Type mismatch
                            cast = Choose(iType + 1, Empty, Null)
        Case vbArray:       cast = IIf(IsArray(iVar), iVar, Array(iVar))
        Case vbDate:        cast = CDate(iVar)
        Case vbString:      cast = CStr(iVar)
        Case vbInteger:     cast = CInt(iVar)
        Case vbLong:        cast = CLng(iVar)
        Case vbDouble:      cast = CDbl(iVar)
        Case vbDecimal:     cast = CDec(iVar)
        Case vbByte:        cast = CByte(iVar)
        Case vbSingle:      cast = CSng(iVar)
        Case vbCurrency:    cast = CCur(iVar)
        Case Else:          cast = CVar(iVar)
    End Select
 
Exit_Hanlder:
    Exit Function
Err_Handler:
    If iStrong Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
    cast = iVar
End Function