This is an old revision of the document!
Schreibt eine Liste in lesbarer Form
Das Modul hat eine Kompilierbedinung. MS Access kennt den Befehl NZ(), MS Excel kennt den nicht. Um in Excel den Befehl zu verwenden habe ich die NZ-Funktion nachgebaut und in eine Bedingte Komplilierung gesetzt. Darum muss am Anfang vom Code eingestellt werden, ob der CODE unter MS Access läuft oder nicht
'------------------------------------------------------------------------------- ' -- ! SETTINGS ! '------------------------------------------------------------------------------- 'In Excel funktionieren Events nicht. Auch der NZ() gibt es dort nicht. 'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable #Const isAccess = True .... #If Not isAccess Then '/** ' * Wandelt NULL in EMpty oder einen Defaultwert ' * @param Variant ' * @param Variant ' * @return Variant ' */ Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant If IsNull(iValue) Then NZ = iDefault Else NZ = iValue End If End Function #End If
Attribute VB_Name = "udf_printList" '------------------------------------------------------------------------------- 'File : udf_printList.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/access/functions/printlist 'Environment : VBA 2010 + 'Version : 1.1.1 'Name : udf_printList 'Author : Stefan Erb (ERS) 'History : 02.02.2016 - ERS - Creation ' 17.07.2017 - ERS - Neuer Parameter iFormats mitgegeben ' 04.09.2019 - ERS - Array() durch emptyArrayVariant() ersetzt '------------------------------------------------------------------------------- Option Explicit '------------------------------------------------------------------------------- ' -- ! SETTINGS ! '------------------------------------------------------------------------------- 'In Excel funktionieren Events nicht. Auch der NZ() gibt es dort nicht. 'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable #Const isAccess = True '------------------------------------------------------------------------------- ' -- Private Members '------------------------------------------------------------------------------- Private Declare Function emptyArrayVariant Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbVariant, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Variant() '/** ' * Die Auswahl an Möglichkeiten zur Ausgabe ' */ Public Enum enuPrintListOutputMethode prListConsole = 2 ^ 0 'Direktfenster prListReturn = 2 ^ 1 'Als Rückgabewert prListClipboard = 2 ^ 2 'In den Zwieschenspeicher des PCs prListMsgBox = 2 ^ 3 'Als MassegeBox ausgeben End Enum '/** ' * Diese Methode schreibt Daten in eine lesbarer Form ' * @param Array<Array<Variant>> Ein verschachtelter Array. Array<Zeilen<Werte>> ' * @param Array<Varaint> Titlezeile. Ist fakultativ. ' * @param enuPrintListOutputMethode Art der Rückgabe: Standart ist das Direktfenster. Alternativ kann man auch als Rückgabewert der ' * Funktion oder in den Zwieschnepseicher des PCs schreiben. ' * Die Auswahlen lassen sich auch kombinieren: prConsole+prClipboard ' * @param Array<String> Ein Array mit dFormaten um die Daten zu formatieren. Siehe auch format() von VBA ' * @retrun String Resultat oder Fehlermeldung ' */ Public Function printList( _ ByRef iData As Variant, _ Optional ByRef iHeader As Variant = Null, _ Optional ByVal iReturn As enuPrintListOutputMethode = prListConsole, _ Optional ByRef iFormats As Variant = Null _ ) As String On Error GoTo Err_Handler Dim colUBound As Long Dim dataR() As Variant If IsArray(iHeader) Then colUBound = UBound(iHeader) If Not IsArray(iData) Then Exit Function If Not IsArray(iData(UBound(iData))) Then ReDim dataR(0) dataR(0) = iData Else dataR = iData End If Dim row As Variant: For Each row In iData colUBound = greatest(UBound(row), colUBound) Next row ' If colUBound = 0 Then GoTo Exit_Handler If IsArray(iHeader) Then ReDim Preserve iHeader(0 To colUBound) If Not IsArray(iFormats) Then iFormats = emptyArrayVariant() ReDim Preserve iFormats(0 To colUBound) Dim fldW() As Long: ReDim fldW(colUBound) 'Fieldwith Dim trenn() As String: ReDim trenn(colUBound) 'Leerer Stringarra für die Trennlinie zwischen Header und Daten Dim dataS() As Variant: ReDim dataS(LBound(iData) To UBound(iData)) 'Der Datenarray, bereits als Strings formatiert Dim dataRowDelta As Long: dataRowDelta = LBound(iData) Dim outLBound As Long: outLBound = IIf(IsNull(iHeader), 0, -2) If IsArray(iHeader) Then 'Die Headerbezeichnungen als Minimale Feldlänge nehmen Dim colNr As Long: For colNr = 0 To UBound(iHeader) fldW(colNr) = Len(iHeader(colNr)) Next colNr End If 'Die Feldbreiten ermitteln Dim rows As Variant: rows = emptyArrayVariant(): Dim rowNr As Long: For rowNr = LBound(dataR) To UBound(dataR) ReDim rows(LBound(dataR(rowNr)) To colUBound) For colNr = LBound(dataR(rowNr)) To UBound(dataR(rowNr)) 'Feld formatieren rows(colNr) = format(dataR(rowNr)(colNr), iFormats(colNr)) fldW(colNr) = greatest(fldW(colNr), Len(rows(colNr))) Next colNr dataS(rowNr) = rows Next rowNr 'Die Returnzeilen erstellen Dim retLines() As String: ReDim retLines(outLBound To UBound(iData) - dataRowDelta) 'Den Header schreiben If IsArray(iHeader) Then retLines(-2) = writeLine(fldW, iHeader) retLines(-1) = writeLine(fldW, trenn, "-|-", "-") End If 'Die Daten schreiben For rowNr = LBound(dataR) To UBound(dataR) retLines(rowNr - dataRowDelta) = writeLine(fldW, dataS(rowNr)) Next rowNr 'Die Zeilen zu einem String zusammenführen Dim retVal As String: retVal = Join(retLines, vbCrLf) Exit_Handler: 'Ausgabe an ImmadiateWindow If (iReturn And prListConsole) = prListConsole Then Debug.Print retVal 'Wert zurückgeben If (iReturn And prListReturn) = prListReturn Then printList = retVal 'Wert in die Zwieschenablage kopieren If (iReturn And prListClipboard) = prListClipboard Then toClipboard retVal 'Wert als MsgBox ausgeben If (iReturn And prListMsgBox) = prListMsgBox Then MsgBox retVal, vbInformation + vbOKOnly, "printList" Exit Function Err_Handler: retVal = "Error " & Err.Number & ": " & Err.Description Resume Exit_Handler Resume End Function '/** ' * Schreibt eine Zeile mit den entsprechenen feldlängen ' * @param Array<Long> Die Feldlängen ' * @param Array<String> Die Values ' * @param String Seperator ' * @param String Pad-Zeichen Private Function writeLine( _ ByRef iFldW() As Long, _ ByRef iValues As Variant, _ Optional ByVal iSeperator As String = " | ", _ Optional ByVal iPadString As String = " " _ ) As String Dim fields() As String: ReDim fields(UBound(iFldW)) Dim value As Variant Dim i As Long: For i = 0 To UBound(iValues) If IsNumeric(iValues(i)) Then fields(i) = Right(iValues(i), iFldW(i)) fields(i) = String(iFldW(i) - Len(fields(i)), iPadString) & fields(i) Else fields(i) = Left(iValues(i), iFldW(i)) fields(i) = fields(i) & String(iFldW(i) - Len(fields(i)), iPadString) End If Next i writeLine = Join(fields, iSeperator) End Function '/** ' * Gibt den Grössten aus einer unbestimmten Menge von Werten zurück ' * @link http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/greatest ' * @param Keine Objekte ' * @return Grösster Wert ' * @example greatest("Hallo Welt", 42, "Mister-X") -> Mister-X '*/ Private Function greatest(ParamArray iItems() As Variant) As Variant greatest = iItems(UBound(iItems)) Dim item As Variant: For Each item In iItems If NZ(item) > NZ(greatest) Then greatest = item Next item End Function '/** ' * http://desmondoshiwambo.wordpress.com/2012/02/23/how-to-copy-and-paste-text-tofrom-clipboard-using-vba-microsoft-access/ ' * ' * Text in den Zwieschenspeicher des PCs schreiben ' * @param String ' */ Private Sub toClipboard(ByVal inText As String) Dim objClipboard As Object Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objClipboard.SetText inText objClipboard.PutInClipboard Set objClipboard = Nothing End Sub #If Not isAccess Then '/** ' * Wandelt NULL in EMpty oder einen Defaultwert ' * @param Variant ' * @param Variant ' * @return Variant ' */ Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant If IsNull(iValue) Then NZ = iDefault Else NZ = iValue End If End Function #End If