[VBA] rx_replace_callback()

Die Erweiterung von [VBA] rx_replace() ist das rx_replace_callback(). Damit kann man alle Treffer einer Callback-Funktion übergeben. Die Submatches sind die Argumente, welche der Funktion übergeben werden

Übersicht über alle rx-Funktionen: [VBA] RegExp Functions (RX-Functins)
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r()

Die Funktion rx_replace_callback() verwendet den MS Access-Befehl eval(). In anderen Applikationen läuft sie nicht. Alternativ kann man die Funktion aus MS Access einbinden (sofern MS Access auf dem Rechner isntalliert ist): [VBA] Eval() und Nz() in MS Excel

Public Function preg_replace_callback( _
	ByVal iPattern As String, _
	ByRef iCallback As Variant, _
	ByVal iSubject As String, _
        Optional ByVal iArrayFlags As rxArrayEnum = rxIncludeSubmatches _
) As String

• iPattern Der Reguläre Ausdruck, mit dem gesucht wird
• iCallback Name der Funktion die mit jedem Treffer aufgerufen werden soll
• iSubject Der Text der durchsucht werden soll
• iFlags Eigenschaften von Regexp. Global, IgnoreCase und Multiline. Die Eigenschaften können mit + kombiniert werden

Setzte die Flags für das RegExp Object. Für das genaue Verhalten bitte die VB-Doku zur RegExp Klasse studieren

• rxNone Alle Parameter werden auf False gesetzt. Wird vor allem zum überschreiben des Standards gebraucht.
• rxGlobal Setzt Global¹⁾ auf True
• rxIgnorCase Setzt IgnorCase²⁾ auf True
• rxMultiline Setzt Multiline auf True

Ich habe eine Funktion getMin(v1,v2) welche den kleineren der Beiden Werte zurückgibt. Nun will ich in einem Text alle 'zwischen v1 und v2' damit berechnen lassen und ersetzen.

Dim txt as String: txt = "wir haben zwischen 1 und 4 Biere und zwischen 5 und 3 Weine"
debug.print rx_replace_callback("zwischen (\d+) und (\d+)", "getMin", txt)

• Eingabe: 'wir haben zwischen 1 und 4 Biere und zwischen 5 und 3 Weine'
• Ausgabe: 'wir haben 1 Biere und 3 Weine'

Public Function createOfficeEmail(ByVal iNachname As String, ByVal iVorname As String) As String
    Dim rndId As Integer
    Randomize
    rndId = Int((9 * Rnd) + 1)  'Zahl zwischen 1 und 9
    createOfficeEmail = iVorname & "." & iNachname & "." & rndId & "@myOffice.com"
End Function
 
Dim txt As String
txt = "Erb Stefan, Yaslaw Kowalejeff, Peter Maier"
Debug.Print rx_replace_callback("(\w+) (\w+)", "createOfficeEmail", txt)
'Ausgabe:
'Stefan.Erb.1@myOffice.com, Kowalejeff.Yaslaw.3@myOffice.com, Maier.Peter.4@myOffice.com

preg_replace_callback.bas

'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/pregreplacecallback
' * Führt eine Callback-Funktion über alle Trefferelemente aus und ersetzt diese im Text
' * @example            Ein Beispiel. ich habe eine Funktion getMin(v1,v2) welche den kleineren der Beiden Werte zurückgibt.
' *                     Nun will ich in einem Text alle 'zwieschen v1 und v2' damit berechnen lassen und ersetzen
' *                     Print preg_replace_callback("zwieschen (\d) und (\d)", "getMin", "wir haben zwieschen 1 und 4 Biere und zwieschen 5 und 3 Weine")
' *                     Eingabe: 'wir haben zwieschen 1 und 4 Biere und zwieschen 5 und 3 Weine'
' *                     Ausgabe: 'wir haben 1 Biere und 3 Weine'
' * @param  String      Pattern analog RegExp
' * @param  String      Name der Callback-Funktion
' * @param  String      Der String der bearbeitet werden soll
' * @param  Boolean     Multiline-Eigenschaft von RegExp
' * @param  Boolean     IgnoreCase-Eigenschaft von RegExp
' * @param  Boolean     Global-Eigenschaft von RegExp
' * @return String
' */
Public Function rx_replace_callback( _
        ByVal iPattern As String, _
        ByRef iCallback As Variant, _
        ByVal iSubject As String, _
        Optional ByVal iFlags As rxFlagsEnum = rxGlobal + rxIgnorCase _
) As String
    'Dim rx      As New regExp
    'Dim mc      As MatchCollection
    'Dim m       As Match
    Dim rx      As Object: Set rx = CreateObject("VBScript.RegExp")
    Dim mc      As Object
    Dim m       As Object
    Dim smc()   As String
    Dim ret     As String
    Dim i, k
 
    rx.Global = iFlags And rxGlobal
    rx.IgnoreCase = iFlags And rxIgnorCase
    rx.Multiline = iFlags And rxMultiline
 
    rx.Pattern = iPattern
    Set mc = rx.execute(iSubject)
 
    rx_replace_callback = iSubject
    For i = mc.count - 1 To 0 Step -1
        Set m = mc.Item(i)
        'Alle Submatches zu Argumenten zusammenführen
        ReDim smc(m.SubMatches.count - 1)
        For k = 0 To UBound(smc): smc(k) = """" & m.SubMatches(k) & """": Next k
        ret = CStr(Eval(iCallback & "(" & join(smc, ",") & ")"))
        'Unterstring ersetzen
        rx_replace_callback = Left(rx_replace_callback, m.FirstIndex) & ret & Mid(rx_replace_callback, m.FirstIndex + m.Length + 1)
    Next i
 
    Set m = Nothing
    Set mc = Nothing
    Set rx = Nothing
 
End Function