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