Attribute VB_Name = "udf_list" '------------------------------------------------------------------------------- 'File : udf_list.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/list 'Environment : VBA 2010 + 'Version : 1.1.1 'Name : list 'Author : Stefan Erb (ERS) 'History : 27.02.2014 - ERS - Creation ' 09.10.2014 - ERS prüfung auf isMissing() hinzugefügt, ref()hinzugefügt ' 09.10.2015 - ERS Methode ref() auf Private umgestellt '------------------------------------------------------------------------------- Option Explicit Public Const LIST_ERR_NO_PARAMS = vbObjectError + 5000 '/** ' * Diese Funktion schreibt die Werte einer Auflistung in Variablen. Fast so wie list() in PHP. list() ist geeignet um ein Array, Collection etc. in Variablen zu zerteilen. ' * @param Liste Array, Dictionary, Collection, Regexp.MatchCollection, Regexp.Match oder DAO.Recordset ' * @param Array Auflistung der Variablen, die abgefüllt werden ' * @return Boolean Angabe, ob die ganze Sache gültig war ' */ Public Function list( _ ByRef iList As Variant, _ ParamArray oParams() As Variant _ ) As Boolean Dim lBnd As Long: lBnd = 0 Dim uBnd As Long: uBnd = UBound(oParams) Dim i As Long On Error GoTo Err_Handler If uBnd = -1 Then Err.Raise LIST_ERR_NO_PARAMS, "list", "No Parameters" 'Array If IsArray(iList) Then If lBnd < LBound(iList) Then lBnd = LBound(iList) If uBnd + lBnd > UBound(iList) Then uBnd = UBound(iList) - lBnd list = True 'Bei einem nicht initialisertem Array generierendie vorherenden Zeilen bereits ein Fehler -> Code abgebrochen, Return: False For i = 0 To uBnd If Not IsMissing(oParams(i)) Then ref oParams(i), iList(lBnd + i) Next 'Dictionary ElseIf TypeName(iList) = "Dictionary" Then list = iList.Count > 0: If Not list Then Exit Function Dim keys As Variant: keys = iList.keys If uBnd > iList.Count - 1 Then uBnd = iList.Count - 1 For i = 0 To uBnd If Not IsMissing(oParams(i)) Then ref oParams(i), iList(keys(i)) Next i 'Collection ElseIf TypeName(iList) = "Collection" Then list = iList.Count > 0: If Not list Then Exit Function If uBnd > iList.Count - 1 Then uBnd = iList.Count - 1 For i = 0 To uBnd If Not IsMissing(oParams(i)) Then ref oParams(i), iList(i + 1) Next i 'MatchCollection ElseIf TypeName(iList) = "IMatchCollection2" Then list = iList.Count > 0: If Not list Then Exit Function If uBnd > iList.Count - 1 Then uBnd = iList.Count - 1 For i = 0 To uBnd If Not IsMissing(oParams(i)) Then oParams(i) = iList(i).value Next i 'Match ElseIf TypeName(iList) = "IMatch2" Then list = iList.subMatches.Count > 0: If Not list Then Exit Function If uBnd > iList.subMatches.Count - 1 Then uBnd = iList.subMatches.Count - 1 For i = 0 To uBnd If Not IsMissing(oParams(i)) Then oParams(i) = iList.subMatches(i) Next i 'Recorset ElseIf TypeName(iList) = "Recordset2" Then list = Not iList.BOF And Not iList.EOF: If Not list Then Exit Function If uBnd > iList.fields.Count - 1 Then uBnd = iList.fields.Count - 1 For i = 0 To uBnd If Not IsMissing(oParams(i)) Then oParams(i) = iList(i) Next i Else Err.Raise 13 'Type mismatch End If Exit_Handler: Exit Function Err_Handler: list = False GoSub Exit_Handler End Function '/** ' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht. ' * Diese Sub nimmt einem die Arbeit ab ' * ref(oNode, iNode) ' * @param Variant Variable, die den Wert bekommen soll ' * @param Variant Ret Wert selber ' */ Private Sub ref(ByRef oNode As Variant, ByRef iNode As Variant) If IsObject(iNode) Then: Set oNode = iNode: Else: oNode = iNode End Sub