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.1.0
'Name         : strReplace
'Author       : Stefan Erb (ERS)
'History      : 04.09.2014 - ERS - Creation
'               08.09.2014 - ERS - neue Version cDict() implementiert
'-------------------------------------------------------------------------------
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

'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------

Private Const C_RX_ESCAPE_PATTERNS = "([\\\*\+\?\|\{\[\(\)\^\$\.\#])"
Private Const C_RX_PATTERN_PATTERNS = "^([@&!/~#=\|])(.*)\1([igm]{0,3})$"

Private Const C_RX_SETSTRING_PATTERN = "(?:(['""#])(?!\\)(.+?)\1(?!\\)|([0-9\.]+?))\s*(?:>=|[:=])\s*(?:\]([^\[]+)\[|(['""])(?!\\)(.+?)\5(?!\\)|(\w+))"
Private Const C_RX_REMOVEMARKS_PATTERN = "\\(['""])"

'Cache
Private rxCachedPattern As Object
Private rxCachedEscapeStrings As Object
Private rxCachedSetString As Object
Private rxCachedRemoveMarks As Object

Private Enum arrFlags
    flRx = 0
    flReplace = 1
    flType = 2
End Enum

'-------------------------------------------------------------------------------
' -- 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 = cDict(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, rxpIgnorCase), 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, rxpGlobal + rxpIgnorCase)        '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(flRx).Test(mc(idxM).value) Then
                strReplace = substrReplace( _
                        iString:=strReplace, _
                        iReplacement:=arr(flRx).Replace(mc(idxM).value, arr(flReplace)), _
                        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
    If rxCachedEscapeStrings Is Nothing Then Set rxCachedEscapeStrings = cRegExp(C_RX_ESCAPE_PATTERNS, rxpGlobal)
    Set rxEscapeStrings = rxCachedEscapeStrings
End Property

Private Property Get rxRemoveMarks() As Object
    If rxCachedRemoveMarks Is Nothing Then Set rxCachedRemoveMarks = cRegExp(C_RX_REMOVEMARKS_PATTERN, rxpGlobal)
    Set rxRemoveMarks = rxCachedRemoveMarks
End Property

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

'/**
' * Wandelt verschiedene Formate in ein Dictionary um
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdict
' * Version      : 2.0.1
' * @param  ParamArray
' * @return Dictionary
' */
Private Function cDict(ByRef iItems() As Variant) As dictionary
    Set cDict = New dictionary
    Dim items() As Variant: items = CVar(iItems)
    Dim i As Integer, 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
            key = items(0): value = items(1)
            Dim delta As Long: delta = LBound(key) - LBound(value)
            ReDim Preserve value(LBound(value) To UBound(key) + delta)
            For i = LBound(key) To UBound(key)
                If Not cDict.exists(key(i)) Then cDict.add key(i), value(i + delta)
            Next i
            Exit Function
        End If
    End If
    
    'Alle Items durchackern
    For i = 0 To UBound(items)
        Dim item As Variant: ref item, items(i)
        'Dictionary
        If Not isList And TypeName(item) = "Dictionary" Then
            For Each key In items(i).keys
                If Not cDict.exists(key) Then cDict.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 cDict.exists(key) Then cDict.add key, item(key)
            Next key
        'SetString
        ElseIf Not isList And rxSetString.Test(StrReverse(item)) Then
            Dim mc As Object: Set mc = rxSetString.execute(StrReverse(item))
            Dim k As Integer: For k = mc.count - 1 To 0 Step -1
                Dim m As Object: Set m = mc(k)
                key = StrReverse(firstValue(m.SubMatches(6), m.SubMatches(5), m.SubMatches(3)))
                value = StrReverse(firstValue(m.SubMatches(2), m.SubMatches(1)))
                Select Case m.SubMatches(0)
                    Case "#":   value = eval("#" & value & "#")
                    Case Empty: value = CDec(value)
                    Case Else:  value = cRegExp("\\(['""])", rxpGlobal).Replace(value, "$1")
                End Select
                If Not cDict.exists(key) Then cDict.add key, value
            Next k
        'Alles andere geht in ein WertePaar.
        ElseIf i = 0 Or isList Then
            If i Mod 2 = 0 Then
                key = item
            Else
                If Not cDict.exists(key) Then cDict.add key, item
            End If
            isList = True
        End If
    Next i
    'Falls es sich um eine nicht abgeschlossene Liste handelt
    If isList And i Mod 2 <> 0 Then
        If Not cDict.exists(key) Then cDict.add key, Empty
    End If
End Function

'-------------------------------------------------------------------------------
'-- Private methodes / properties for cDict()
'-------------------------------------------------------------------------------
'/**
' * Gibt den ersten Wert zurück, der nicht Nothing, Empty oder Null ist
' * @param  ParamArray
' * @return Variant
' */
Private Function firstValue(ParamArray items() As Variant) As Variant
    For Each firstValue In items
        If IsObject(firstValue) Then
            If Not firstValue Is Nothing Then Exit For
        Else
            If Not IsNull(firstValue) And Not firstValue = Empty Then Exit For
        End If
    Next
End Function

'/**
' * Gibt eine Refernez auf den Wert zurück
' * @param  Variant     Variable, di abgefüllt werden soll
' * @param  Variant     Value
' */
Private Sub ref(ByRef oItem As Variant, Optional ByRef iItem As Variant)
    If IsMissing(iItem) Then
        oItem = Empty
    ElseIf IsObject(iItem) Then
        Set oItem = iItem
    Else
        oItem = iItem
    End If
End Sub

'/**
' * Handelt den RegExp-Cache um ein Set-String zu zerlegen
' * @return RegExp
' */
Private Property Get rxSetString() As Object
    If rxCachedSetString Is Nothing Then
        Set rxCachedSetString = CreateObject("VBScript.RegExp")
        rxCachedSetString.Global = True
        rxCachedSetString.pattern = C_RX_SETSTRING_PATTERN
    End If
    Set rxSetString = rxCachedSetString
End Property



'/**
' * 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, Optional ByVal iFlag As rxpFlagsEnum = rxnone) 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*"
    Else
        cRegExp.pattern = iPattern
        cRegExp.Global = iFlag And rxpGlobal
        cRegExp.IgnoreCase = iFlag And rxpIgnorCase
        cRegExp.Multiline = iFlag And rxpMultiline
    End If
End Function
Private Property Get rxPattern() As Object
    If rxCachedPattern Is Nothing Then
        Set rxCachedPattern = CreateObject("VBScript.RegExp")
        rxCachedPattern.pattern = C_RX_PATTERN_PATTERNS
    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