User Tools

Site Tools


vba:access:functions:printrs

[VBA][Access] printRs()

Gibt den Inhalt einer Tabelle/Abfrage/Recordsets im Textformat aus.

Version 1.6.1 (21.12.2015)

printRs() ist dazu gedacht, schnell die ersten X Zeilen einer Quelle (Tabelle, Abfrage, Recordset etc) als fornatierten Text auszugeben. Das ist praktisch für Debug-Zwecke, um Beispiele zu Funktionen zu dokumentieren oder um Tabelleninhalte/Resultate in ein Forum zu posten.

Wird zum Beispiel in der [VBA][Access] Klasse SQLScript verwendet

Download udf_printrs.bas (V-1.6.1)

Definition

printRs(SELECT-Statement [,limit [,returnType[, cancel]]])
printRs(recordset [,limit [,returnType[, cancel]]])
printRs(tabellenname [,limit [,returnType[, cancel]]])
printRs(TableDef [,limit [,returnType[, cancel]]])
printRs(viewname [,limit [,returnType[, cancel]]])
printRs(QueryDef [,limit [,returnType[, cancel]]])
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

Parameter-Liste

  • iRs <Variant> (income)
    Mark text as key press Das offene DAO.Recordset. Es wird als ByVal übergeben und verändert somit das Original nicht. Es kann ein Recordet, ein SELECT-Statement, Tabellenname oder Abfragename sein
  • iLimit <Integer> (income)
    Maximal auszugebende Zeilen. Wenn die Zahl negativ ist, wird die Anzahl Zeilen vom Ende an ausgegeben
  • iReturn <enuPrintRsOutputMethode> (optional income)
    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.
  • oCancel <Boolean> (Otional outgoing)
    Rückgabeflag, ob der Print_Rs aus einem Grund abgebrochen wurde

Enumerator

enuPrintRsOutputMethode

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

  • prsConsole(1) Die Ausgabe wird ins Direktfenster geschrieben
  • prsReturn(2) Die Ausgabe wird als Funktionsrückgabewert zurückgegeben
  • prsClipboard(4) Die Ausgabe wird in den Zwieschenspeicher geschrieben
  • prsMsgBox(8) Die Ausgabe wird als Popup ausgegeben

Beispiele

Direkt im Immadiate-Window

'Resultat einer Abfrage
printrs "vw_pivot_source"
| w1 | <> | 1 | 2 | 4 |
|----|----|---|---|---|
| 1  |    | 2 |   |   |
| 2  |    |   | 1 |   |
| 3  |    |   | 1 | 1 |
| 4  | 0  |   |   |   |
 
'Erste 5 Zeilen eines Recorsets
printrs currentdb.OpenRecordset("my_table"), 5
| ID | f_date              | f_string | f_double  |
|----|---------------------|----------|-----------|
| 1  | 14.03.2014 00:01:00 | abcd     | 1.15      |
| 2  | 23.06.2014 11:06:10 | bv       | 4         |
| 3  | 14.03.2014 00:03:00 | dd       | 165413.58 |
| 4  | 14.03.2014 00:17:00 | dsf      | 0.134     |
| 11 | 14.03.2014 00:10:00 |          | 0.5       |
 
'Rückgabe als String
?printrs("my_table", 5, prsReturn)
| ID | f_date              | f_string | f_double  |
|----|---------------------|----------|-----------|
| 1  | 14.03.2014 00:01:00 | abcd     | 1.15      |
| 2  | 23.06.2014 11:06:10 | bv       | 4         |
| 3  | 14.03.2014 00:03:00 | dd       | 165413.58 |
| 4  | 14.03.2014 00:17:00 | dsf      | 0.134     |
| 11 | 14.03.2014 00:10:00 |          | 0.5       |
 
'Direktes Auswerten eines SQL-Befehls
printrs "SELECT id, f_double FROM my_table ORDER BY f_double DESC", 5
| id | f_double   |
|----|------------|
| 3  | 165413.58  |
| 22 | 16546.1654 |
| 25 | 8694.1     |
| 12 | 156        |
| 18 | 151.584    |

Code

udf_printrs.bas
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.6.1
'Name         : printRs
'Author       : Stefan Erb (ERS)
'History      : 27.05.2014 - ERS - Creation
'               ....
'               11.12.2015 - ERS - Mehrfachauswahl in Feld (Complex) hinzugefügt
'               21.12.2015 - ERS - SHOW COLUMNS angepasst
'-------------------------------------------------------------------------------
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 ausgeben
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      Resultat oder Fehlermeldung
' */
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
                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) = CStr(NZ(rs.fields(i).value))
                End If
                ln(i) = greatest(Len(row(i)), 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 prsConsole) = prsConsole Then Debug.Print retVal
    'Wert zurückgeben
    If (iReturn And prsReturn) = prsReturn Then printRs = retVal
    'Wert in die Zwieschenablage kopieren
    If (iReturn And prsClipboard) = prsClipboard Then toClipboard retVal
    'Wert als MsgBox ausgeben
    If (iReturn And prsMsgBox) = prsMsgBox Then MsgBox retVal, vbInformation + vbOKOnly, "printRs"
    Exit Function
Err_Handler:
    retVal = "Error " & Err.Number & ": " & Err.description
    oCancel = True
    Resume Exit_Handler
    Resume
End Function
 
'-------------------------------------------------------------------------------
' -- Libraries
'-------------------------------------------------------------------------------

'/**
' * http://http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/pad
' *
' * 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
 
'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/greatest
' *
' * 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
 
'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/least
' *
' * 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
 
 
'/**
' * 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
 
'/**
' * 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
 
'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/increment
' *
' * PreIncrement    ++i
' * Zählt i eins hoch und gibt den Wert zurück
' * @param  Number
' * @return Number
'*/
Private Function inc(ByRef i As Variant) As Variant
    i = i + 1: inc = i
End Function
 

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/access/functions/printrs.txt · Last modified: 21.12.2015 09:52:26 by yaslaw