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