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.0.0
'Name         : strReplace
'Author       : Stefan Erb (ERS)
'History      : 04.09.2014 - ERS - Creation
'-------------------------------------------------------------------------------
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_STRINGDICT_PATTERN = "(?:(['""#])(?!\\)(.+?)\1(?!\\)|([0-9\.]+?))\s*>=\s*(?:\]([^\[]+)\[|(\w+))"
Private Const C_RX_REMOVEMARKS_PATTERN = "\\(['""])"

'Cache
Private rxCachedPattern As Object
Private rxCachedEscapeStrings As Object
Private rxCachedStringDict 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 = 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, 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 = CreateObject("VBScript.RegExp")
        rxCachedEscapeStrings.pattern = C_RX_ESCAPE_PATTERNS
        rxCachedEscapeStrings.Global = True
    End If
    Set rxEscapeStrings = rxCachedEscapeStrings
End Property

Private Property Get rxStringDict() As Object
    If rxCachedStringDict Is Nothing Then Set rxCachedStringDict = cRegExp(C_RX_STRINGDICT_PATTERN, rxpGlobal)
    Set rxStringDict = rxCachedStringDict
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
'-------------------------------------------------------------------------------

'/**
' * Erstellt aus unterschiedlichen Eingaben ein Dictionary
' * @param  Array
' * @return Dictionary
Public Function cDictA(ByRef items() As Variant) As dictionary
    Set cDictA = New dictionary
'    Dim items() As Variant: items = CVar(iItems)
    If UBound(items) = -1 Then Exit Function
    Dim i As Integer
    Dim key As Variant
    Dim value As Variant

    'Abklären ob es sich um ein Combine handelt
    If UBound(items) = 1 Then
        If IsArray(items(0)) And IsArray(items(1)) Then
            key = items(0)
            value = items(1)
            Dim delta As Long: delta = LBound(key) - LBound(value)
            For i = LBound(key) To UBound(key)
                Dim v As Variant
                If UBound(value) < i + delta And UBound(value) = -1 Then
                    v = Null
                ElseIf UBound(value) < i + delta Then
                    v = value(UBound(value))
                Else
                    If Not cDictA.exists(key(i)) Then cDictA.add key(i), value(i + delta)
                    v = value(i + delta)
                End If
                If Not cDictA.exists(key(i)) Then cDictA.add key(i), v
            Next i
            Exit Function
        End If
    End If
    
    Dim flagOpenCombi As Boolean: flagOpenCombi = False
    For i = 0 To UBound(items)
        If TypeName(items(i)) = "Dictionary" Then
            For Each key In items(i).keys
                If Not cDictA.exists(key) Then cDictA.add key, items(i).item(key)
            Next key
        ElseIf VarType(items(i)) = vbString Then
            If rxStringDict.Test(StrReverse(items(i))) Then
                Dim m As Object: For Each m In rxStringDict.execute(StrReverse(items(i)))
                    key = StrReverse(IIf(isEmpty(m.SubMatches(3)) Or m.SubMatches(3) = Empty, m.SubMatches(4), m.SubMatches(3)))
                    value = StrReverse(IIf(isEmpty(m.SubMatches(1)) Or m.SubMatches(1) = Empty, m.SubMatches(2), m.SubMatches(1)))
                    Select Case m.SubMatches(0)
                        Case "#":   value = eval("#" & value & "#")
                        Case Empty: value = CDec(value)
                        Case Else:  value = rxRemoveMarks.Replace(value, "$1")
                    End Select
                    If Not cDictA.exists(key) Then cDictA.add key, value
                Next m
            Else: GoTo DEFAULT
            End If
        Else
DEFAULT:
            If Not flagOpenCombi Then
                key = items(i)
                flagOpenCombi = True
            Else
                value = items(i)
                If Not cDictA.exists(key) Then cDictA.add key, value
                flagOpenCombi = False
            End If
        End If
    Next i
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, 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