Attribute VB_Name = "udf_splitPlus" '------------------------------------------------------------------------------- 'File : cast_cArray.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba 'Environment : VBA 2010 + 'Version : 1.1.0 'Name : cArray 'Author : Stefan Erb (ERS) 'History : 24.03.2015 - ERS - Creation ' 07.10.2016 - ERS - Neu lassen sich Delimiter und Seperatoren mit \ maskieren. zudem werden Leerstring jetzt richtig gehandhabt '------------------------------------------------------------------------------- Option Explicit ' /** ' * Ähnlich wie split. Zusätzlich ' * Einzelne Elemente können in Anführungszeichen gesetzt sein. ' * @param String ' * @param String Delimiter Default: , ' * @param String Quota ' * @return Array ' */ Public Function splitPlus(ByVal iString As String, Optional ByVal iDelimiter As String = ",", Optional ByVal iQuote As String = """") As String() Static rxCache As Dictionary: If rxCache Is Nothing Then Set rxCache = New Dictionary Dim rxKey As String: rxKey = iDelimiter & iQuote '/(?:'([^']+)'|([^,]+))/g If Not rxCache.exists(rxKey) Then rxCache.add rxKey, cRx("/\s*(?:" & iQuote & "([^" & iQuote & "]+)" & iQuote & "|([^" & iDelimiter & "]+))\s*/g") iString = masked2uniode(iString) If Not rxCache(rxKey).test(iString) Then splitPlus = Array(iString): Exit Function With rxCache(rxKey).execute(iString) Dim retArr() As String: ReDim retArr(.count - 1) Dim i As Long: For i = 0 To .count - 1 retArr(i) = Trim(unicodeDecode(.item(i).subMatches(0) & .item(i).subMatches(1))) If retArr(i) = iQuote & iQuote Then retArr(i) = Empty Next i End With splitPlus = retArr End Function '/** ' * Dies ist die Minimalversion von cRegExp ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version ' * mögliche Delemiter: @&!/~#=\| ' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline) ' * ' * @example myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase ' * @version 2.1.0 (01.12.2014) ' * @param String Pattern mit Delimiter und Modifier analog zu PHP ' * @return Object RegExp-Object ' */ Private Function cRx(ByVal iPattern As String) As Object Static rxP As Object: Set cRx = CreateObject("VBScript.RegExp") If rxP Is Nothing Then: Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$" Dim sm As Object: Set sm = rxP.execute(iPattern)(0).subMatches cRx.pattern = sm(1): cRx.IgnoreCase = Not isEmpty(sm(2)): cRx.Global = Not isEmpty(sm(3)): cRx.Multiline = Not isEmpty(sm(4)) End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * http:/wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/masked2unicode ' * ' * Wandelt jedes mit \ maskierte Feld in Unicode um, ausser es handelt sich bereits um einen Unicode ' * @param String ' * @return String ' */ Private Function masked2uniode(ByVal iString As String) As String Static rx As Object If rx Is Nothing Then Set rx = CreateObject("VBScript.RegExp"): rx.pattern = "\\(?!\\?u[0-9A-F]{4})(.)" masked2uniode = iString Do While rx.test(masked2uniode) 'Logik siehe auch http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/char2unicode Dim unicode As String: unicode = rx.execute(masked2uniode)(0).subMatches(0) unicode = Hex(AscW(unicode)) 'Hex-Wert ermitteln unicode = "\u" & String(4 - Len(unicode), "0") & unicode masked2uniode = rx.Replace(masked2uniode, unicode) Loop End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * http:/wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/unicodedecode ' * ' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück ' * @param String ' * @return String ' */ Private Function unicodeDecode(ByVal iString As String) As String unicodeDecode = iString Static rx As Object: If rx Is Nothing Then Set rx = CreateObject("VBScript.RegExp"): rx.pattern = "\\u[0-9A-F]{4}" Do While rx.test(unicodeDecode) unicodeDecode = rx.Replace(unicodeDecode, ChrW(Replace(rx.execute(unicodeDecode)(0), "\u", "&h"))) Loop End Function