User Tools

Site Tools


vba:functions:printlist

[VBA] printList()

Schreibt eine Liste in lesbarer Form

Version 1.0.0 - 02.02.2016

Beschreibung

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

Definitionen

printList(DataArray [,HeaderArray [,ReturnOptionen]])
Public Function printList( _
    ByRef iData As Variant, _
    Optional ByRef iHeader As Variant = Null, _
    Optional ByVal iReturn As enuPrintListOutputMethode = prListConsole _
) 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
  • Return String Resultat oder Fehlermeldung

Settings

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

Beispiele

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

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

Code

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.0.0
'Name         : udf_printList
'Author       : Stefan Erb (ERS)
'History      : 02.02.2016 - ERS - Creation
'-------------------------------------------------------------------------------

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
 
 
'/**
' * 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  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
' * @retrun String                      Resultat oder Fehlermeldung
' */
Public Function printList( _
    ByRef iData As Variant, _
    Optional ByRef iHeader As Variant = Null, _
    Optional ByVal iReturn As enuPrintListOutputMethode = prListConsole _
) As String
On Error GoTo Err_Handler
    Dim colUBound As Long
    If IsArray(iHeader) Then
        colUBound = UBound(iHeader)
    ElseIf IsArray(iData) Then
        If IsArray(iData(LBound(iData))) Then
            colUBound = UBound(iData(LBound(iData)))
        End If
    End If
 
    If colUBound = 0 Then GoTo Exit_Handler
 
    Dim fldW() As Long:             ReDim fldW(colUBound)
    Dim trenn() As String:          ReDim trenn(colUBound)
    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 rowNr As Long: For rowNr = LBound(iData) To UBound(iData)
        For colNr = 0 To UBound(iData(rowNr))
            fldW(colNr) = greatest(fldW(colNr), Len(iData(rowNr)(colNr)))
        Next colNr
    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(iData) To UBound(iData)
        retLines(rowNr - dataRowDelta) = writeLine(fldW, iData(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(CStr(iValues(i)), iFldW(i))
            fields(i) = String(iFldW(i) - Len(fields(i)), iPadString) & fields(i)
        Else
            fields(i) = Left(CStr(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
 
 
 

Discussion

Enter your comment. Wiki syntax is allowed:
If you can't read the letters on the image, download this .wav file to get them read to you.
 
vba/functions/printlist.txt · Last modified: 29.02.2016 09:56:28 by yaslaw