Yaslaw.Info

User Tools

Site Tools

You are here: Yaslaw.Info » VBA » Functions » [VBA] compaire()
Trace:
vba:functions:compaire

Differences

This shows you the differences between two versions of the page.

Link to this comparison view

Both sides previous revision Previous revision
Next revision 		Previous revision
vba:functions:compaire [16.09.2014 11:21:51]
yaslaw [[VBA] compaire()] 		vba:functions:compaire [29.04.2015 10:52:23] (current)
yaslaw
Line 1: Line 1:
 +<​const>​
 +    version=1.0.1
 +    vdate=19.09.2014
 +    fname=udf_compaire.bas
 +    ns=%NAMESPACE%
 +    fpath=/​vba/​functions
 +</​const>​
 +{{keywords>​vba,​function,​compaire,​array,​object,​dictionary}}
 +{{description>​Eine Funktion zum Vergleichen. Klingt eigentlich unnötig. Doch vergleicht sie alles Mögliche. Arrays untereinander,​ Dictionaries,​ Null mit Empty etc.}}
 +
 ====== [VBA] compaire() ====== ====== [VBA] compaire() ======
-Eine Funktion zum Vergleichen. Klingt eigentlich unnötig. Doch vergleicht sie alles Mögliche.+//Eine Funktion zum Vergleichen. Klingt eigentlich unnötig. Doch vergleicht sie alles Mögliche.
 Arrays untereinander,​ Dictionaries,​ Null mit Empty etc. Arrays untereinander,​ Dictionaries,​ Null mit Empty etc.
 +//
 +==Version %%version%% %%vdate%%==
 +
 +{{%%fname%%|Download %%fname%% (V-%%version%%)}}
  
-{{:​vba:​functions:​udf_compaire.bas|Download udf_compaire.bas}} 
 ===== Definitionen ===== ===== Definitionen =====
  
Line 86: Line 99:
  
 ===== Code ===== ===== Code =====
-<code vb udf_compaire.bas>​Attribute VB_Name = "​udf_compaire"​ +<source ​'%%fpath%%/%%fname%%' ​vb>
-'------------------------------------------------------------------------------- +
-'​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 +
-</code>+
vba/functions/compaire.1410859311.txt.gz · Last modified: 16.09.2014 11:21:51 by yaslaw

Page Tools

Except where otherwise noted, content on this wiki is licensed under the following license: GNU Free Documentation License 1.3
GNU Free Documentation License 1.3 Donate Powered by PHP Valid HTML5 Valid CSS Driven by DokuWiki