This is an old revision of the document!
Eine Funktion zum Vergleichen. Klingt auf 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 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.0 'Name : compaire 'Author : Stefan Erb (ERS) 'History : 12.09.2014 - ERS - Creation '------------------------------------------------------------------------------- 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 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 '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 IsArray(iVar1) And IsArray(iVar2) Then compaire = LBound(iVar1) = LBound(iVar2) And UBound(iVar1) = UBound(iVar2) If compaire Then Dim i As Integer: For i = LBound(iVar1) To UBound(iVar1) compaire = compaire(iVar1(i), iVar2(i), iParams) If Not compaire Then Exit Function Next i End If '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 Dim k As Integer: 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.0 ' * @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 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