Erweiterter CStr()

Download cast_cstrf.bas (V-1.0.0)

Inteligentere Umsetzung des VBA-Befehls CStr. Die Funktion erkennt auch Objekte mit dem Interface IFormattable. Zudem sind diverse weitere Objekte/Typen abgedeckt.

Im Code gibt es 2 Einstellungen, die die Möglchkeiten steuern. Da ich diese Funktion für mich geschrieben habe, habe ich auch einige Methoden und Objekte, die sin in meiner Library befinden zur Verfügung. Diese sind aber nicht zwingend. Mit den folgenden Einstellungen kann angegeben werden, ob die Module verfügbar sind.

Angabe, ob das Modul lib_json in diesem Projekt vorhanden ist oder nicht
#Const lib_json_exists = True

Das Interface IFormattable ist in diesem Projekt vorhanden
#Const IFormattable_exists = True

Public Function cStrF( _
        ByRef iValue As Variant, _
        Optional ByVal iparams As csfParams = csfListAsJson + csfNullAsEmpty, _
        Optional ByVal iDelemiter As String = ", " _
) As String

• iValue Item das zu einem String geparst werden soll
• iparams Paramter um das Verhalten von CStrF zu steuern
• iDelemiter String

csfParams

Public Enum csfParams
    csfNon = 0                      'Kein Parameter aktiv
    csfListAsJson = 2 ^ 0           'Falls die Library lib_json die Listen (Array, Dictionary etc) als Json-String zurückgeben. Ansonsten als Werteliste mit Komma getrennt
    csfRegExpOnlyPattern = 2 ^ 1    'Bei einem Regexp nur den Pattern zurückgeben
    csfNullAsEmpty = 2 ^ 2          'Null und Nothing als Empty zurückgeben
 
    csfIsSubItem = 2 ^ 9            'Wird nur Intern benutzt
End Enum

Hier einige Anwendungsbeispiele

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

Dictionaries sind im Beispieldirekt mit [VBA] cDict() erstellt.

? cStrF(array(1,2,3))
[1,2,3]
 
? cStrF(array(1,2,3), csfNon, "#")
1#2#3
 
? cStrF(array(1,2,array(1,22,33)))
[1,2,[1,22,33]]
 
'Verschachtelter Array
? cStrF(array(1,2,array(1,22,33)), csfNon)
1, 2, (1, 22, 33)
 
'Dictionary anzeigen
print_r cDict("a", 12, "b", array(22, 33))
<Dictionary>  (
    [a] => <Integer> 12
    [b] => <Variant()>  (
        [0] => <Integer> 22
        [1] => <Integer> 33
    )
)
 
 
'und mittels cStrF ausgeben. 
'Ist lib_json vorhanden, wird der Dictionary als json-String ausgegeben
? cstrf(cDict("a", 12, "b", array(22,33)))
{"a":12,"b":[22,33]}
 
'Ansnsten gehen die Keys verloren
? cstrf(cDict("a", 12, "b", array(22,33)), csfNon)
12, (22, 33)

print_r cStrF(Null)
<String> ''
 
print_r cStrF(Nothing)
<String> ''

Solche Klassen können dierkt geparst werden. Die folgenden Klassen kommen in den Beispielen vor: [VBA] DateTime + DateInterval, [VBA] Iterator

'DateTime
? cStrF(DateTime().add("P3D"))
#2016-06-26 12:00:51#
 
'DateInterval
? cStrF(DateTime(#12/31/2015#).diff(date()))
P5M23D
? cStrF(DateInterval.instancePart("M", 3))
P3M
 
'Iterator
'Wenn der Cursor nocht nicht positioniert ist, wird der Erste Wert ausgegeben
?cStrF(Iterator(array(1,2,3)))
1
 
'Ansonsten der aktuelle
?cStrF(Iterator(array(1,2,3)).toPosition1(2))
3

tbd

cast_cstrf.bas

Attribute VB_Name = "cast_cstrF"
'-------------------------------------------------------------------------------
'File         : cast_cstrf.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki
'Environment  : VBA 2007 +
'Version      : 1.0.0
'Name         : cstrf
'Author       : Stefan Erb (ERS)
'History      : 21.06.2016 - ERS - Creation
'-------------------------------------------------------------------------------
Option Explicit
 
'-------------------------------------------------------------------------------
' -- ! SETTINGS !
'-------------------------------------------------------------------------------
 
'Angabe, ob das Modul lib_json in diesem Projekt vorhanden ist oder nicht
'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/json
#Const lib_json_exists = True
 
'Das Interface IFormattable ist in diesem Projekt vorhanden
'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/iformattable
#Const IFormattable_exists = True
 
'-------------------------------------------------------------------------------
' -- Definitions
'-------------------------------------------------------------------------------
 
'/**
' * Paramter um das Verhalten von CStrF zu steuern
' */
Public Enum csfParams
    csfNon = 0                      'Kein Parameter aktiv
    csfListAsJson = 2 ^ 0           'Falls die Library lib_json installiert ist, die Listen (Array, Dictionary etc) als Json-String zurückgeben. Ansonsten als Werteliste mit Komma getrennt
    csfRegExpOnlyPattern = 2 ^ 1    'Bei einem Regexp nur den Pattern zurückgeben
    csfNullAsEmpty = 2 ^ 2          'Null und Nothing als Empty zurückgeben
    csfNotCastableToError = 2 ^ 3   'Wenn etwas nicht geparst werden kann, dann wird ein Error geworfen. Ansonsten kommt der Text #TypeName zurück (zB. #Form)
 
    csfIsSubItem = 2 ^ 9            'Wird nur Intern benutzt
End Enum
 
Public Const C_CSTRF_PARSE_ERROR = vbObjectError + 123
 
'-------------------------------------------------------------------------------
' -- Public methodes
'-------------------------------------------------------------------------------
'/**
' * Inteligentere Umsetzung des VBA-Befehls CStr
' * Die Funktion erkennt auch Objekte mit dem Interface IFormattable
' * Zudem sind diverse weitere Objekte/Typen abgedeckt
' * @param  Variant     Value der zu einem String geparst werden soll
' * @param  csfParams   Paramter um das Verhalten von CStrF zu steuern
' * @retrun String
' */
Public Function cStrF( _
        ByRef iValue As Variant, _
        Optional ByVal iparams As csfParams = csfListAsJson + csfNullAsEmpty, _
        Optional ByVal iDelemiter As String = ", " _
) As String
    Dim values() As String
    Dim i As Long
On Error Resume Next
    'Standard CStr
    cStrF = CStr(iValue)
    If Err.Number = 0 Then Exit Function
    'toString Methode
    Err.clear
    cStrF = iValue.toString
    If Err.Number = 0 Then Exit Function
#If IFormattable_exists Then
    'IFormattable
    Err.clear
    Dim tfb As IFormattable: Set tfb = iValue
    cStrF = tfb.toString
    If Err.Number = 0 Then Exit Function
#End If
#If lib_json_exists Then
    'Array, Dictionary, Collection -> Json
    If andB(iparams, csfListAsJson) Then
        Err.clear
        cStrF = obj2json(iValue)
        If Err.Number = 0 Then Exit Function
    End If
#End If
    'Array, Dictionary
    Err.clear
    If TypeName(iValue) = "Dictionary" Then iValue = iValue.itemS   'Die Items als Array aus dem Dictionary extrahieren
    If IsArray(iValue) Then
        'Bei einem Array alle items parsen und zusammenhängen
        ReDim values(LBound(iValue) To UBound(iValue))
        For i = LBound(iValue) To UBound(iValue)
            values(i) = cStrF(iValue(i), iparams + IIf(Not andB(iparams, csfIsSubItem), csfIsSubItem, 0), iDelemiter)
        Next i
        cStrF = Join(values, iDelemiter)
        If andB(iparams, csfIsSubItem) Then cStrF = "(" & cStrF & ")"
        If Err.Number = 0 Then Exit Function
    End If
    'Nach speziellen Typen
    Err.clear
On Error GoTo Err_Handler
    Select Case TypeName(iValue)
        'Null, Nothing
        Case "Null", "Nothing":    cStrF = IIf(andB(iparams, csfNullAsEmpty), Empty, notCastable(iValue, iparams))
        'RegExp -> Gibt den pattern inkl. Paramters zurück
        'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#beispiele_mit_patterns_inkl_den_parametern
        Case "IRegExp2":
            cStrF = iValue.pattern
            If Not andB(iparams, csfRegExpOnlyPattern) Then cStrF = "/" & cStrF & "/" & IIf(iValue.IgnoreCase, "i", "") & IIf(iValue.Global, "g", "") & IIf(iValue.Multiline, "m", "")
        'MatchCollection
        Case "IMatchCollection2":
            If iValue.Count = 0 Then Exit Function
            ReDim values(iValue.Count - 1)
            For i = 0 To iValue.Count - 1
                values(i) = iValue(i).value
            Next i
            cStrF = cStrF(values, iparams, iDelemiter)
        'Nur den Typenname ausgeben
        Case Else:          cStrF = notCastable(iValue, iparams)
    End Select
 
Exit_Handler:
    Exit Function
Err_Handler:
    cStrF = notCastable(iValue, iparams)
    Resume Exit_Handler
End Function
 
'-------------------------------------------------------------------------------
' -- Private Methodes / Libraries
'-------------------------------------------------------------------------------
'/**
' * Handel den Fall, dass ein Wert nicht in String geparst werden kann
' * @param  Variant     Value der zu einem String geparst werden soll
' * @param  csfParams   Paramter um das Verhalten von CStrF zu steuern
' * @retrun String
' */
Private Function notCastable(ByRef iValue As Variant, ByVal iparams As csfParams) As String
    'Falls Fehler gewünscht werden, diese ausgeben
    If andB(iparams, csfNotCastableToError) Then Err.Raise C_CSTRF_PARSE_ERROR, , "cStrF: Type " & TypeName(iValue) & " is not castable"
    notCastable = "#" & TypeName(iValue)
End Function
 
'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/andb
' * Macht einen Bit-Vergleich
' * @param  Long
' * @param  Long
' * @return Boolean
' */
Private Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean
    andB = ((iHaystack And iNeedle) = iNeedle)
End Function