Attribute VB_Name = "udf_inSet" '------------------------------------------------------------------------------- 'File : udf_inSet.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/strtodate 'Environment : VBA 2007 + 'Version : 1.3.0 'Name : inSet 'Author : Stefan Erb (ERS) 'History : 30.04.2014 - ERS - Creation ' 27.06.2014 - ERS - Die Mögliche hinzugefügt, Arrays zu übergeben ' 28.08.2014 - ERS - Neu mit Listenstring als Paramter: inset(2, "1,2,3") ' 11.09.2014 - ERS - Array-Vergleich hinzugefügt '------------------------------------------------------------------------------- Option Explicit Private Const C_VALUELIST_DELEMITER = "," '/** ' * Prüft ein Wert gegen eine Liste von Werten. ' * Dient als Ersatz des Befehls IN(), den man in vielen anderen Sprachen kennt ' * Kann auch als in_array dienen ' * Bei Objekten geht es nur auf dieselbe Instanz. ' * ' * found = inSet(search, value1 [,value2... [,value#]]) ' * found = inSet(search, valueList) ' * ' * @example inset(2, 1, 2, 3) => true ' * @example inset(2, array(1, 2, 3)) => true ' * @example inset(2, array(1, 2), 3) => true ' * @example inset(3, 1, array(2, 3)) => true ' * @example inset(3, "1,2,3,4,5") ' * @example inset(array(1,2), 3, 4, array(1,2)) => true ' * @example inset(array(1,2), 3, 4, array(2, 1)) => false ' * ' * @param Variant Wert der gesucht wird ' * @paramArray Werte gegen die geprüft wird. Sind die Werte Arrays, werden die Arrays durchsucht ' * @return Boolean Flag ob der Wert gefunden wird Public Function inSet(ByRef iSearch As Variant, ParamArray iItems() As Variant) As Boolean inSet = inSetArray(iSearch, CVar(iItems)) End Function ' * @param Variant Wert der gesucht wird ' * @param Array Werte gegen die geprüft wird. Sind die Werte Arrays, werden die Arrays durchsucht ' * @return Boolean Flag ob der Wert gefunden wird Private Function inSetArray(ByRef iSearch As Variant, ByRef iItems As Variant) As Boolean If TypeName(iItems(0)) = "String" And UBound(iItems) = 0 Then iItems = Split(iItems(0), C_VALUELIST_DELEMITER) End If Dim item As Variant: For Each item In iItems inSetArray = compaire(iSearch, item) If inSetArray Then Exit Function Next item End Function '/** ' * Vergleicht 2 Variaben ' * @param Variant ' * @param Variant ' * @return Boolean ' */ Private Function compaire(ByRef iVar1 As Variant, ByRef iVar2 As Variant) As Boolean 'Null Vergleich If IsNull(iVar1) Or IsNull(iVar2) Then compaire = IsNull(iVar1) = IsNull(iVar2) 'in Array vergleichen ElseIf IsArray(iVar1) And IsArray(iVar2) Then ' compaire = compaireArray(iVar1, iVar2) compaire = LBound(iVar1) = LBound(iVar2) And UBound(iVar1) And UBound(iVar2) If compaire Then Dim i As Integer: For i = LBound(iVar1) To UBound(iVar1) compaire = compaire(iVar1(i), iVar2(i)) If Not compaire Then Exit Function Next i End If 'in Array suchen ElseIf IsArray(iVar2) Then compaire = inSetArray(iVar1, iVar2) 'Objekt-Vergleich ElseIf IsObject(iVar1) And IsObject(iVar2) Then compaire = (iVar1 Is iVar2) '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 ' * @param VbVarType ' * @param Variant ' * @return Variant ' */ Private Function cast(ByVal iType As VbVarType, ByVal iFind As Variant) As Variant If IsNumeric(iFind) Then Select Case iType Case vbInteger: cast = CInt(iFind) Case vbLong: cast = CLng(iFind) Case vbDouble: cast = CDbl(iFind) Case vbDecimal: cast = CDec(iFind) Case vbByte: cast = CByte(iFind) Case vbSingle: cast = CSng(iFind) Case vbCurrency: cast = CCur(iFind) Case Else: cast = CVar(iFind) End Select ElseIf IsDate(iFind) And iType = vbDate Then cast = CDate(iFind) Else cast = iFind End If End Function