Attribute VB_Name = "udf_printRs"
'-------------------------------------------------------------------------------
'File         : udf_printRs.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/access/functions/printrs
'Environment  : VBA 2010 +
'Version      : 1.5.1
'Name         : list
'Author       : Stefan Erb (ERS)
'History      : 27.05.2014 - ERS - Creation
'               ....
'               08.04.2015 - ERS - ADODB.Recordset hinzugefügt
'               09.04.2015 - ERS - Fehlerhandling hinzugefügt
'-------------------------------------------------------------------------------
Option Explicit

'/**
' * Die Auswahl an Möglichkeiten zur Ausgabe
' */
Public Enum enuPrintRsOutputMethode
    prsConsole = 2 ^ 0       'Direktfenster
    prsReturn = 2 ^ 1        'Als Rückgabewert
    prsClipboard = 2 ^ 2     'In den Zwieschenspeicher des PCs
    prsMsgBox = 2 ^ 3        'Als MassegeBox asugeben
End Enum

'/**
' * Diese Funktion dient zu Debug/Programmierzwecken. Sie macht in einem fertigen Program keinen Sinn mehr
' * Schreibt die ersten [iLimit] Zeilen in das Direktfenster
' *
' *     printRs(SELECT-Statement [,limit [,returnType]])
' *     printRs(recordset [,limit [,returnType]])
' *     printRs(tabellenname [,limit [,returnType]])
' *     printRs(TableDef [,limit [,returnType]])
' *     printRs(viewname [,limit [,returnType]])
' *     printRs(QueryDef [,limit [,returnType]])
' *
' * @param  Recordset/String    Recordset, SELECT-String, Tabellenname oder ViewName
' * @param  Integer             Limit der Zeilen. Default 10.
' *                     Positiv:    Es werden die iLimit Anzahl Zeilen ausgegeben.
' *                     0:          Es werden alle Zeilen ausgegeben
' *                     Negativ:    Es werden die iLimit letzten Zeilen ausgegen
' * @param  enuPrintRsOutputMethode
' *                     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  Boolean     Rückgabeflag, ob der Print_Rs aus einem Grund abgebrochen wurde
' * @retrun String
' */
Public Function printRs( _
        ByVal iRs As Variant, _
        Optional ByVal iLimit As Integer = 10, _
        Optional ByVal iReturn As enuPrintRsOutputMethode = prsConsole, _
        Optional ByRef oCancel As Boolean = False _
) As String
    Dim qdf As QueryDef
    Dim rs As Object
    Dim db As DAO.Database: Set db = CurrentDb
On Error GoTo Err_Handler

    Select Case typeName(iRs)
        'Input ist ein String -> Als SQL/Tablename/Viewname handeln
        Case "String":                  Set rs = db.OpenRecordset(iRs, dbReadOnly)
        Case "Recordset":               Set rs = iRs.clone  'ADODB.Recordset
        Case "Recordset2":              Set rs = iRs.clone  'DAO.Recordset
        Case "QueryDef":                Set rs = iRs.OpenRecordset(dbOpenSnapshot)
        Case "TableDef":                Set rs = db.OpenRecordset("SELECT * FROM [" & iRs.Name & "]", dbReadOnly)
        Case Else:                      Err.Raise 438       '438     Object doesn't support this property or method
    End Select
    'Max anz. Zeilen zum ausgeben
    Dim limit       As Integer:
        If Not rs.BOF Then
            rs.MoveLast
            limit = IIf(iLimit = 0, rs.RecordCount, least(Abs(iLimit), rs.RecordCount) * Sgn(iLimit))
        End If
    Dim fldCnt      As Integer: fldCnt = rs.fields.count - 1    'Anzahl Felder
    Dim ln()        As Integer: ReDim ln(fldCnt)                'Array mit der grössten Länge jeder Spalte
    Dim hdr()       As String:  ReDim hdr(fldCnt)               'Array mit dem Header
    Dim tren()      As String:  ReDim tren(fldCnt)              'Array mit den Trennzeichen pro Spalte
    Dim row         As Variant: ReDim row(fldCnt)               'Zeile
    Dim rowsUbound  As Long:    rowsUbound = IIf(rs.BOF, 0, Abs(limit) - 1)
    Dim rows()      As Variant: If Not rs.BOF Then ReDim rows(rowsUbound)      'Zeilen
    Dim retRows()   As String:  ReDim retRows(IIf(rs.BOF, -1, rowsUbound) + 2)
    
    'Spaltenüberschriften auslesen
    Dim i As Long: For i = 0 To rs.fields.count - 1
        hdr(i) = rs.fields(i).Name
        ln(i) = Len(rs.fields(i).Name)
    Next i
    
    'Startpunkt setzen
    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        Dim idx As Integer: For idx = 0 To rowsUbound
            If rs.EOF Then  'Bei übergabe von TabeDef kann es passieren, dass rs.RecordCount() zu viele Zeilen ausspuckt.
                ReDim Preserve rows(idx - 1)
                Exit For
            End If
            For i = 0 To rs.fields.count - 1
                row(i) = CStr(NZ(rs.fields(i).value))
                ln(i) = greatest(Len(CStr(NZ(rs.fields(i).value))), ln(i))
            Next i
            rows(idx) = row
            rs.Move Sgn(limit) '1
        Next idx
    End If
    For idx = 0 To fldCnt
        hdr(idx) = rPad(hdr(idx), ln(idx))
        tren(idx) = String(ln(idx), "-")
    Next idx
    retRows(0) = "| " & Join(hdr, " | ") & " |"
    retRows(1) = "|-" & Join(tren, "-|-") & "-|"
    
    If Not rs.BOF Then
        Dim rnr As Integer: For rnr = 0 To UBound(rows)
            For idx = 0 To fldCnt
                rows(rnr)(idx) = rPad(rows(rnr)(idx), ln(idx), " ")
            Next idx
            retRows(rnr + 2) = "| " & Join(rows(rnr), " | ") & " |"
        Next rnr
    End If
    Dim retVal As String: retVal = Join(retRows, vbCrLf)
    
Exit_Handler:
    'Ausgabe an ImmadiateWindow
    If (iReturn And prConsole) Then Debug.Print retVal
    'Wert zurückgeben
    If (iReturn And prReturn) Then printRs = retVal
    'Wert in die Zwieschenablage kopieren
    If (iReturn And prClipboard) Then toClipboard retVal
    'Wert als MsgBox ausgeben
    If (iReturn And prMsgBox) Then MsgBox retVal
    Exit Function
Err_Handler:
    retVal = "Error " & Err.Number & ": " & Err.Description
    oCancel = True
    Resume Exit_Handler
End Function

'/**
' * Füllt einen String mit einem Zeichen auf die gewünschte Länge auf oder kürzt ihn auf die Länge
' * @param  String      Ausgangsstring
' * @param  Integer     Länge des resultates
' * @param  String*1    Zeichen zum auffüllen
' * @return String
' */
Private Function rPad(ByVal iStr As String, ByVal iLen As Integer, Optional ByVal iPadStr As String = " ") As String
    Dim padStr As String * 1: padStr = Left(iPadStr, 1)
    If iLen > Len(iStr) Then
        rPad = iStr & String(iLen - Len(iStr), padStr)
    Else
        rPad = Left(iStr, iLen)
    End If
End Function

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Gibt den Grössten aus einer unbestimmten Menge von Werten zurück
' * @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

'/**
' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück
' * @param  Keine Objekte
' * @return Grösster Wert
' * @example least("Hallo Welt", 42, "Mister-X") -> 42
'*/
Private Function least(ParamArray iItems() As Variant) As Variant
    least = iItems(LBound(iItems))
    Dim item As Variant: For Each item In iItems
        If NZ(item) < NZ(least) Then least = item
    Next item
End Function

'/**
' *Text in den Zwieschenspeicher des PCs schreiben
'  * @see   http://desmondoshiwambo.wordpress.com/2012/02/23/how-to-copy-and-paste-text-tofrom-clipboard-using-vba-microsoft-access/
' */
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