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.
Download udf_list.bas (V-1.1.1)
Dieselbe Technik verende ich auch bei der Klasse [VBA] Iterator.
Iterator→list() und Iterator→listNext()
Public Function list( _ ByRef iList, _ ParamArray oParams() As Variant _ ) As Boolean
list() gibt ein Boolean zurück.Je nachdem, ob die iList abgearbeitet werde kann oder nicht
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().
Der Array kann mit Index 0 beginnen oder auch einen anderen LBound haben. Indiesem Beispiel get der Index von 1 bis 4
Public Sub testList() Dim myArray(1 To 4) As Variant Dim retA As Integer, retB As String, retC As Variant 'Array abfüllen. Es ist egal, ob der Array einen lbound() von 0 oder etwas anderem hat myArray(1) = 1 myArray(2) = "B" myArray(3) = Null myArray(4) = "iv" 'Weniger Variablen übergeben als Werte im Array sind list myArray, retA, retB, retC 'Variabeln begutachten print_rm retA, retB, retC End Sub
<Integer> 1 <String> B <Null>
Collection und Dictionary funktionieren gleich. Bei beiden werden die Keys verworfen
Public Sub testList() Dim myCol As New Collection Dim retA As Integer, retB As String, retC As Variant 'Array abfüllen myCol.add 1 myCol.add "B" myCol.add Null myCol.add "iv" list myCol, retA, retB, retC 'Variabeln begutachten print_rm retA, retB, retC End Sub
<Integer> 1 <String> B <Null>
In diesem Beispiel verwende ich die meine eigenen RegExp Funktionen, Geht aber mit der Standartanwednung von RegExp
Public Sub testList() Dim mc As MatchCollection Dim von As Variant, nach As Variant, x As Variant, y As Variant Dim i As Long Set mc = rx_match("([A-H])([1-8])", "Springer von A1 auf B3") Debug.Print "//Auswertung MatchCollection:" list mc, von, nach print_rm von, nach Debug.Print "//Auswertung Matches:" For i = 0 To mc.count - 1 Debug.Print "//Index " & i list mc(i), x, y print_rm x, y Next i End Sub
//Auswertung MatchCollection: <String> A1 <String> B3 //Auswertung Matches: //Index 0 <String> A <String> 1 //Index 1 <String> B <String> 3
In diesem Beispiel arbeite ich mit dem Rückgabewert um ein Recordset abzuarbeiten
Public Sub testList() Dim rs As DAO.Recordset Dim id As Integer, nr1 As Long, nr2 As Long Set rs = CurrentDb.OpenRecordset("SELECT id, number_one, number_two FROM [_test]") Do While list(rs, id, nr1, nr2) Debug.Print id & ": " & nr1 & " + " & nr2 & " = " & nr1 + nr2 rs.MoveNext 'Nicht vergessen. list() macht keinen Vorschub! Loop End Sub
1: 3 + 5 = 8 2: 4 + 8 = 12 3: 5 + 2 = 7 4: 7 + 5 = 12
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<Varaint> 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