Schreibt eine Liste in lesbarer Form

Download udf_printlist.bas (V-1.1.1)

Siehe auch [VBA] printRef()

Mit dieser Methode kann eine Liste sauber ausgegeben werden- Ich verwende sie zum Beispiel für die Methode [VBA] printRef().

printList(DataArray [,HeaderArray [,ReturnOptionen [,FormatArray]]])

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

• iData Array<Array<Variant» Ein verschachtelter Array. Array<Zeilen<Werte»
• iHeader Array<String> Ein Array mit dem Header
• iReturn 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
• iFormats Ein Array mit dFormaten um die Daten zu formatieren. Siehe auch format() von VBA
• Return String Resultat oder Fehlermeldung

Auswahl was mir der Analyse geschehen soll. Die Werte lassen sich mit + kombinieren

• prListConsole(1) Die Ausgabe wird ins Direktfenster geschrieben
• prListReturn(2) Die Ausgabe wird als Funktionsrückgabewert zurückgegeben
• prListClipboard(4) Die Ausgabe wird in den Zwieschenspeicher geschrieben
• prListMsgBox(8) Die Ausgabe wird als Popup ausgegeben

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

Das Beispiel macht so natürlich keinen Sinn, zeigt aber wie der Aufbaeu der Parameter sein muss

printlist array(array(1,2,3, date()), array(11,22,33, date()+1)), array("A", "B", "C", "D")
A  | B  | C  | D         
---|----|----|-----------
 1 |  2 |  3 | 29.02.2016
11 | 22 | 33 | 01.03.2016

Ein Beispiel ohne Header, dafür ist die 2te Spalte formatiert

printlist array(array(1, 2, "abc"), array(1.5, 2345.6, null)),,,array(,"#,##0.00")
  1 |     2.00 | abc
1.5 | 2'345.60 |    

Einweiteres Beispiel ist die Funktion [VBA] printRef().

udf_printlist.bas

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