Attribute VB_Name = "udf_strReplace"
'-------------------------------------------------------------------------------
'File         : udf_strReplace.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions
'Environment  : VBA 2010 +
'Version      : 1.2.0
'Name         : strReplace
'Author       : Stefan Erb (ERS)
'History      : 04.09.2014 - ERS - Creation
'               08.09.2014 - ERS - neue Version cDict() implementiert
'               31.10.2014 - ERS - Cache auf Static umgestellt
'               12.11.2014 - ERS - auf cDict V.3.0.0 upgraded
'-------------------------------------------------------------------------------
Option Explicit

Public Const ERR_strReplace_INVALID_ARGUMENT_COUNT = vbObjectError + 501   'Der ParamArray hat eine ungerade Anzahl Argumente

'Modifier i IgnoreCase
'Modifier m Multiline
'Modifier g Global

'-------------------------------------------------------------------------------
' -- Public metodes
'-------------------------------------------------------------------------------

'/**
' * Ersetz in einem String mehrere Substrings. Normal oder mit RegExp
' * @param  String      Der Text, ind em ersetzt werden soll
' * @param  ParamArray  Die Ersetzungsargumente
' * @return String
' */
Public Function strReplace( _
        ByVal iExpression As Variant, _
        ParamArray iItems() As Variant _
) As String
    Dim items() As Variant: items = CVar(iItems)
    'Parameters zusammenstellen: Dictionary([Pattern] => [Replace])
    Dim dict As Dictionary: Set dict = cDictA(items)
'Set dict = createDictFromExpressions(items)
    'If ((UBound(items) + 1) Mod 2) > 0 Then Err.Raise ERR_strReplace_INVALID_ARGUMENT_COUNT, "Invalid Number of Values"
    'Keys extrahieren, da bei Latebinding nicht über den ndex auf das Dictionary zugegriffen werden kann
    Dim keys() As Variant: keys = dict.keys
    'Aufbrösmeln: repl = array(flRx => [RegExp des einzelnen Suchwertes], flReplace => [Ersatzstring])
    Dim repl() As Variant: ReDim repl(dict.count - 1)
    Dim idxI As Integer: For idxI = 0 To dict.count - 1
        Dim searchPattern As String: searchPattern = keys(idxI)                 'Suchpattern auslesen
        If rxPattern.test(searchPattern) Then                                   'Falls gültiger Pattern
            searchPattern = rxPattern.execute(searchPattern)(0).subMatches(1)   'Den eigentlichen Pattern extrahieren
            repl(idxI) = Array(cRegExp(keys(idxI)), dict(keys(idxI)))            'und den Array zusammenstellen
        Else
            searchPattern = escapeString(searchPattern)                         'Pattern Escapen, damit es kein RegExp-Search gibt
            repl(idxI) = Array(cRegExp("/" & searchPattern & "/i"), dict(keys(idxI)))
        End If
        Dim pp() As String: ReDim Preserve pp(idxI): pp(idxI) = "(" & searchPattern & ")"   'Alle SearchPattern in einme Array sammeln
    Next idxI
    Dim pattern As String: pattern = "(?:" & Join(pp, "|") & ")"                'und zu einem grossen Pattern zusammensetzen: (?(pattern1)|(pattern2)...|(patternN))
    Dim rx As Object: Set rx = cRegExp("/" & pattern & "/gi")        'und damit ein GesammtsuchRegExp erstellen
    
    strReplace = iExpression
    
    Dim mc As Object: Set mc = rx.execute(iExpression)                          'Gesammtsuche ausführen
    Dim idxM As Integer: For idxM = mc.count - 1 To 0 Step -1
        Dim arr As Variant: For Each arr In repl                                'Für jeden Treffer den richtigen TeilRegExp suchen und den Teilstring ersetzen
            If arr(0).test(mc(idxM).value) Then
                strReplace = substrReplace( _
                        iString:=strReplace, _
                        iReplacement:=arr(0).Replace(mc(idxM).value, arr(1)), _
                        iStart:=mc(idxM).firstIndex, _
                        iLength:=mc(idxM).length _
                )
                Exit For
            End If
        Next arr
    Next idxM
    
End Function

'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------

'/**
' * Escapte alle Sonderzeichen um eine rx-Pattern zu erstellen
' *
' *     string = rx_escape_string(string)
' *
' * @example    rx_escape_string("Hallo Welt. Geht es dir (noch) gut?")
' *             Hallo Welt\. Geht es dir \(noch\) gut\?
' * @param  String
' * @return String
' */
Private Function escapeString( _
        ByVal iString As String _
) As String
    escapeString = rxEscapeStrings.Replace(iString, "\$1")
End Function



'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------
Private Property Get rxEscapeStrings() As Object
    Static rxCachedEscapeStrings As Object
    If rxCachedEscapeStrings Is Nothing Then Set rxCachedEscapeStrings = cRegExp("/([\\\*\+\?\|\{\[\(\)\^\$\.\#])/g")
    Set rxEscapeStrings = rxCachedEscapeStrings
End Property

Private Property Get rxRemoveMarks() As Object
    Static rxCachedRemoveMarks As Object
    If rxCachedRemoveMarks Is Nothing Then Set rxCachedRemoveMarks = cRegExp("/\\(['""])/g")
    Set rxRemoveMarks = rxCachedRemoveMarks
End Property

'-------------------------------------------------------------------------------
' -- Private Libraries
'-------------------------------------------------------------------------------

'/**
' * Dito zu cDict(). Die Übergabe ist aber nicht ein ParamArray sondern ein Arry.
' * DIeser AUfruf wird vor allem im Einsatz in anderen Funktionen verwendet
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic
' * @param  Array
' * @return Dictionary
' */
Public Function cDictA(ByRef iItems() As Variant) As Object
    Static rxSetString As Object    'Cache RegExp um einSet-String zu zerlegen
    Set cDictA = CreateObject("scripting.Dictionary")
    Dim items() As Variant:     items = CVar(iItems)
    Dim key As Variant, value As Variant
    Dim isList As Boolean
    
    If UBound(items) = -1 Then Exit Function

    'Prüfen ob 2 Parametetrs übergeben wurden
    If UBound(items) = 1 Then
        'Beide Parametrer sind Arrays -> Combine: Erster Array Keys, 2ter Values
        If IsArray(items(0)) And IsArray(items(1)) Then
            Dim keys() As Variant:      keys = items(0)
            Dim values() As Variant:    values = items(1)
            Dim delta As Long:          delta = LBound(keys) - LBound(values)
            ReDim Preserve values(LBound(values) To UBound(keys) + delta)
            Dim i As Integer: For i = LBound(keys) To UBound(keys)
                If Not cDictA.exists(keys(i)) Then cDictA.add keys(i), values(i + delta)
            Next i
            Exit Function
        End If
    End If
    
    'Alle Items durchackern
    Dim cnt As Integer:     cnt = 0
    Dim item As Variant:    For Each item In items
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In item.keys
                If Not cDictA.exists(key) Then cDictA.add key, item.item(key)
            Next key
        'einsamer Array
        ElseIf Not isList And IsArray(item) Then
            For key = LBound(item) To UBound(item)
                If Not cDictA.exists(key) Then cDictA.add key, item(key)
            Next key
        'SetString
        ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then
            If rxSetString Is Nothing Then Set rxSetString = cRegExp("/((['""#](?![\\,])).+?\1(?!\\)|[\d\.]*)\s*(?:>=|[:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+)/g")
            If rxSetString.test(StrReverse(item)) Then
                Dim mc As Object: Set mc = rxSetString.execute(StrReverse(item))
                Dim m As Variant: For Each m In mc
                    key = evalCDictString(StrReverse(m.subMatches(2)))
                    value = evalCDictString(StrReverse(m.subMatches(0)))
                    If Not cDictA.exists(key) Then cDictA.add key, value
                Next m
            Else
                GoTo DEFAULT        'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt übergeben wird. Darum konnte der Test nicht im ElseIf durchgeführt werden.
            End If
        'Alles andere geht in ein WertePaar.
        ElseIf cnt = 0 Or isList Then
DEFAULT:
            If cnt Mod 2 = 0 Then
                key = item
            ElseIf Not cDictA.exists(key) Then cDictA.add key, item
            End If
            isList = True
        End If
        cnt = cnt + 1
    Next
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And cnt Mod 2 <> 0 Then
        If Not cDictA.exists(key) Then cDictA.add key, Empty
    End If
End Function


'-------------------------------------------------------------------------------
'-- Private methodes / properties for cDict()
'-------------------------------------------------------------------------------

'/**
' * Parst einen String in Datum, Nummer oder String
' * @param  String
' * @return Variant
' */
Private Function evalCDictString(ByVal iString As String) As Variant
    Static rxDateString As Object
    Static rxDelemitedString As Object
    If rxDateString Is Nothing Then Set rxDateString = cRegExp("/^#.*#$/")
    If rxDelemitedString Is Nothing Then Set rxDelemitedString = cRegExp("/^[#""'\[](.*)([""'#\]])$/") '0: String ohne Delemiter, 1: End-Delemiter: '," oder ]

    If IsNumeric(iString) Then
        evalCDictString = eval(iString)  'Zu Zahlenformat konvertieren
    ElseIf rxDateString.test(iString) Then
        evalCDictString = eval(iString)  'Zu Datum konvertieren
    ElseIf rxDelemitedString.test(iString) Then
        Dim sm As Object: Set sm = rxDelemitedString.execute(iString)(0).subMatches
        evalCDictString = Replace(sm(0), "\" & sm(1), sm(1))
    Else
        evalCDictString = iString
    End If
End Function



'/**
' * Erstellt ein RegExp-Object mit den Grundeinstellungen
' * Modifier i IgnoreCase
' * Modifier g Global
' * Modifier m multiLine
' * @param  String          Pattern analog RegExp oder mit Delimiter und Modifier analog zu PHP
' * @param  rxpFlagsEnum    Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return RegExp
' */
Private Function cRegExp(ByVal iPattern As String) As Object
    Set cRegExp = CreateObject("VBScript.RegExp")
    If rxPattern.test(iPattern) Then
        Dim sm As Object: Set sm = rxPattern.execute(iPattern)(0).subMatches
        cRegExp.pattern = sm(1)
        cRegExp.IgnoreCase = sm(2) Like "*i*"
        cRegExp.Global = sm(2) Like "*g*"
        cRegExp.MultiLine = sm(2) Like "*m*"
    End If
End Function
Private Property Get rxPattern() As Object
    Static rxCachedPattern As Object
    If rxCachedPattern Is Nothing Then
        Set rxCachedPattern = CreateObject("VBScript.RegExp")
        rxCachedPattern.pattern = "^([@&!/~#=\|])(.*)\1([igm]{0,3})$"
    End If
    Set rxPattern = rxCachedPattern
End Property

'/**
' * Ersetzt Text innerhalb einer Zeichenkette
' * @param  String      Die Eingabezeichenkette
' * @param  String      Die Ersetzungszeichenkette
' * @param  Integer     Start
' * @param  Integer     Länge
' * @return String
' */
Private Function substrReplace(ByVal iString As String, ByVal iReplacement As String, ByVal iStart As Integer, Optional ByVal iLength As Variant = Null) As String
    Dim startP As Integer:  startP = IIf(Sgn(iStart) >= 0, iStart, greatest(Len(iString) + iStart, 1))
    Dim length As Integer:  length = NZ(iLength, Len(iString) - iStart)
    Dim endP   As Integer
    
    Select Case Sgn(length)
        Case 1:     endP = least(startP + length, Len(iString))
        Case 0:     endP = startP
        Case -1:    endP = greatest(Len(iString) + length, startP)
    End Select
    
    substrReplace = Left(iString, startP) & iReplacement & Mid(iString, endP + 1)
    
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