This is an old revision of the document!
Naja, der Titel ist ev. irreführend. Mir kahm aber kein besserer in den Sinn.
Es geht um folgendes: Mittels eines RegExp ermittle ich Teilstrings. Diese sollen über eine Funktion verändert werden und dann im String den Originalteilstring ersetzen.
Ein kleines Beispiel: den folgende String
Bären und Hüner gehören nicht in Ämter
Jetzt will ich alle äöü und ÜÖÜ in Unicode setzen
B\u00E4ren und H\u00FCner geh\u00F6ren nicht in \u00C4mter
Dazu habe ich mal die Funktion [VBA] char2Unicode(), welche mir einen einzelnen Char nach Unicode wandelt.
Mit RegExp.replace() kann ich bekanntlich keine User-Funktion ausführen. Darum löse ich das meistens wie folgt.
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r()
Die folgende Umsetzung beinhaltet eigentlich bereits die ganze Logik. Zum besseren Verständnis sind noch alle Schritte einzel auugeführt. Die Erklärung ist im Code mit drin.
Public Function replUmlaute(ByVal iString As String) As String Static rx As regExp 'Das RegExp als Statisch definieren, damit es nicht bei jedem AUfruf initialisiert werden muss Dim mc As MatchCollection Dim m As match Dim sm As subMatches Dim unicode As String If rx Is Nothing Then Set rx = New regExp rx.pattern = "([äöü])" rx.IgnoreCase = True 'Die folgedne Zeile müsste ich eigentlich nicht setzen. 'Aber es ist Wichtig, dass Global nicht auf True ist. rx.Global = False End If replUmlaute = iString 'Den folgenden Code-Abschnitt ausführen, bis keine Umlaute mehr vorkommen Do While rx.Test(replUmlaute) 'Der erste Treffer wird zurückgegeben Set mc = rx.execute(replUmlaute) 'Wegen global=Off hat die MatchCollection genau einen Match auf der Position 0 Set m = mc(0) 'Und einen Submatch auf der Position 0 Set sm = m.subMatches 'Den Buchstaben in Unicode wandeln unicode = char2unicode(sm(0)) 'und den ersten Treffer mittels RegExp ersetzen replUmlaute = rx.Replace(replUmlaute, unicode) Loop End Function
d replUmlaute("Bären und Hüner gehören nicht in Ämter") <String> 'B\u00E4ren und H\u00FCner geh\u00F6ren nicht in \u00C4mter'
In dieser Version verzichte ich darauf, alle Schritte einzeln durchzugehen. Auch das ertellen des RegExp überlasse ich der Funktion [VBA] cRegExp() Abgespeckte Version. Dann sieht der Code noch so aus. Ja, der erste ist besser lesbar. Wenn an aber ein Pattern immer wieder verwendet, erkennt man es beim lesen vom Code sofort.
Public Function replUmlaute(ByVal iString As String) As String Static rx As Object: If rx Is Nothing Then Set rx = cRegExp("/([äöü])/i") replUmlaute = iString Do While rx.Test(replUmlaute) replUmlaute = rx.Replace(replUmlaute, char2unicode(rx.execute(replUmlaute)(0).subMatches(0))) Loop End Function
d replUmlaute("Bären und Hüner gehören nicht in Ämter") <String> 'B\u00E4ren und H\u00FCner geh\u00F6ren nicht in \u00C4mter'
Und natürlich das ganze auch wieder zurückwandeln…
Public Function replUmlauteBack(ByVal iString As String) As String Static rx As Object: If rx Is Nothing Then Set rx = cRegExp("/(\\u[\dA-F]{4})/i") replUmlauteBack = iString Do While rx.Test(replUmlauteBack) replUmlauteBack = rx.Replace(replUmlauteBack, unicode2Char(rx.execute(replUmlauteBack)(0).subMatches(0))) Loop End Function
d replUmlauteBack("B\u00E4ren und H\u00FCner geh\u00F6ren nicht in \u00C4mter") <String> 'Bären und Hüner gehören nicht in Ämter'
In den [VBA] JSON setze ich dieses Pattern mehrfach ein.
'/** ' * Erstellt ein RegExp-Object mit den Grundeinstellungen ' * V2.0.1 ' * @param String Pattern mit Delmiter und igm-Parametern ' * @return RegExp ' */ Private Function cRegExp(ByVal iPattern As String) As Object Static rxP As Object 'RegExpo um iPattern aufzubrechen If rxP Is Nothing Then Set rxP = CreateObject("VBScript.RegExp") rxP.pattern = "^([@&!/~#=\|])(.*)\1(?:([Ii])|([Gg])|([Mm]))*$" End If Set cRegExp = CreateObject("VBScript.RegExp") 'Neuer RegExp erstellen If Not rxP.Test(iPattern) Then cRegExp.pattern = iPattern: Exit Function 'Falls es ein einfacher Pattern ist, diesen übernehmen und die Func verlassen Dim parts As Object: Set parts = rxP.execute(iPattern)(0).subMatches 'Pattern zerlegen. 0) Delemiter, 1) Pattern, 2) - 4) Paramters cRegExp.IgnoreCase = Not isEmpty(parts(2)) cRegExp.Global = Not isEmpty(parts(3)) cRegExp.Multiline = Not isEmpty(parts(4)) cRegExp.pattern = parts(1) End Function
Attribute VB_Name = "_cast_char2Unicode" '------------------------------------------------------------------------------- 'File : _cast_char2Unicode.bas ' Copyright mpl by ERB software ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/char2Unicode 'Environment : VBA 2007 + 'Version : 1.0 'Author : Stefan Erb (ERS) 'History : 29.04.2014 - ERS - Creation '------------------------------------------------------------------------------- Option Explicit '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Wandelt ein Charakter in ein Unicode ' * @example: char2unicode("€") -> '\u20AC' ' * @param String(1) Charakter, der gewandelt werden soll ' * @return String Unicode ' */ Public Function char2unicode(ByVal iChar As String) As String char2unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln char2unicode = "\u" & String(4 - Len(char2unicode), "0") & char2unicode End Function
Attribute VB_Name = "_cast_unicode2Char" '------------------------------------------------------------------------------- 'File : _cast_unicode2Char.bas ' Copyright mpl by ERB software ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/unicode2Char 'Environment : VBA 2007 + 'Version : 1.0 'Author : Stefan Erb (ERS) 'History : 29.04.2014 - ERS - Creation '------------------------------------------------------------------------------- Option Explicit '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Wandelt ein Unicode in ein Charakter ' * @example: unicode2char("\u20AC") -> '\€' ' * @param String Unicode ' * @return String Char ' */ Public Function unicode2Char(ByVal iUnicode As String) As String unicode2Char = ChrW(replace(iUnicode, "\u", "&h")) End Function