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      : 3.1.0
'Name         : printRs
'Author       : Stefan Erb (ERS)
'History      : 27.05.2014 - ERS - Creation
'               ....
'               18.07.2017 - ERS - Auf printlist() aufgabut
'               16.08.2017 - ERS - TempTableDef als Argument hinzugefügt -> http://wiki.yaslaw.info/doku.php/vba/access/classes/temptabledef
'-------------------------------------------------------------------------------
Option Explicit

'-------------------------------------------------------------------------------
' !!! WICHTIG !!!
' Diese Funktion verwendet die Funktion printList() http://wiki.yaslaw.info/doku.php/vba/functions/printlist
' Diese Funktion muss also auch im Projekt vorhanden sein
'-------------------------------------------------------------------------------

'/**
' * 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 [,cancel [,formate]]]])
' *     printRs(recordset [,limit [,returnType [,cancel [,formate]]]])
' *     printRs(tabellenname [,limit [,returnType] [,cancel [,formate]]]])
' *     printRs(TableDef [,limit [,returnType [,cancel [,formate]]]])
' *     printRs(viewname [,limit [,returnType [,cancel [,formate]]]])
' *     printRs(QueryDef [,limit [,returnType [,cancel [,formate]]]])
' *     printRs(TemTableDef [,limit [,returnType [,cancel [,formate]]]])
' *
' * @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 PrintRs aus einem Grund abgebrochen wurde
' * @param  Array<String>           Ein Array mit den Formaten um die Daten zu formatieren. Siehe auch format() von VBA
' * @retrun String                  Resultat oder Fehlermeldung
' */
Public Function printrs( _
        ByVal iRs As Variant, _
        Optional ByVal iLimit As Integer = 10, _
        Optional ByVal iReturn As enuPrintListOutputMethode = prListConsole, _
        Optional ByRef oCancel As Boolean = False, _
        Optional ByRef iFormats As Variant = Null _
) As String
    Dim qdf As QueryDef
    Dim rs As Object
    Dim db As DAO.Database: Set db = CurrentDb
    Dim limit As Integer
    Dim retVal As String
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", "Recordset2": Set rs = iRs.clone
        Case "QueryDef", "TableDef":    Set rs = iRs.openRecordset(dbOpenSnapshot)
        Case "TempTableDef":            Set rs = iRs.openRecordset(, dbOpenSnapshot)  'http://wiki.yaslaw.info/doku.php/vba/access/classes/temptabledef
        Case Else:                      Err.Raise 438       '438     Object doesn't support this property or method
    End Select
    'Max anz. Zeilen zum ausgeben
    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 hdr()       As String:  ReDim hdr(fldCnt)               'Array mit dem Header
    Dim rowsUbound  As Long:    rowsUbound = IIf(rs.BOF, 0, Abs(limit) - 1)
    Dim data()      As Variant: ReDim data(rowsUbound)
    Dim row()       As Variant: ReDim row(fldCnt)

    'Spaltenüberschriften auslesen
    Dim i As Long: For i = 0 To rs.fields.count - 1
        hdr(i) = 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 data(idx - 1)
                Exit For
            End If
            rs.absolutePosition = idx
            ReDim row(fldCnt)
            For i = 0 To rs.fields.count - 1
                If getProperty(rs.fields(i), "IsComplex", False) Then
                    Dim rsV As Recordset2: Set rsV = rs.fields(i).value
                    Dim values() As String
                    Dim j As Long: j = -1
                    Do While Not rsV.EOF And Not rsV.BOF
                        ReDim Preserve values(inc(j)): values(j) = rsV!value.value
                        rsV.MoveNext
                    Loop
                    Set rsV = Nothing
                    row(i) = Join(values, ", ")
                Else
                    row(i) = rs.fields(i).value
                End If
            Next i
            data(idx) = row
        Next idx
    End If
    retVal = printList(data, hdr, iReturn, iFormats)
    
Exit_Handler:
    printrs = retVal
    Exit Function
Err_Handler:
    retVal = "Error " & Err.number & ": " & Err.DESCRIPTION
    oCancel = True
    Resume Exit_Handler
    Resume
End Function

'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/
' *
' * Dieverse Objekte in Access besitzen Properties. Diese sind aber nicht immer initialisiert
' * Mit dieser Funktion verscuht man ein Property auszulesen. Wenn dies nicht funktioniert, wird ein Default-Wert zurückgegeben
' * @param  Object      Objekt welches das Property beinhalten sollte
' * @param  Name        Eigenschaftsname
' * @param  Variant     Default-Wert, falls die Eigenschaft nicht exisitiert
' * @return Variant
' */
Private Function getProperty(ByRef iObject As Object, ByVal iName As String, Optional ByRef iDefault As Variant = Null) As Variant
    On Error Resume Next
    If IsObject(iObject.properties(iName)) Then: Set getProperty = iObject.properties(iName): Else: getProperty = iObject.properties(iName)
    If Err.number <> 0 Then
        If IsObject(iDefault) Then: Set getProperty = iDefault: Else: getProperty = iDefault
    End If
End Function