This is an old revision of the document!
Eine Funktion zum Vergleichen. Klingt eigentlich unnötig. Doch vergleicht sie alles Mögliche. Arrays untereinander, Dictionaries, Null mit Empty etc.
'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
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