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