vba:functions:printf:index
This is an old revision of the document!
Table of Contents
%tH:%tM:%tS
[VBA] sprintf(), vsprintf()
Gibt eine anhand des Formatierungs-Strings format gebildete Zeichenkette zurück.1)
Version 2.4.0 - 14.10.2016
Download lib_printf.bas (V-2.4.0)
Von PHP bin ich mir die tolle Funktion sprintf() gewohnt. Diese vermisste ich schmerzlich im VBA. Immer alle Strings mit & zusammenzusetzen war einfach hässlich. Auf der Suche nach einer Lösung fand ich eine printf Implementierung auf der Seite PrintF and Related Functions in VB.
Das fand ich am Anfang auch ganz toll. Doch vermisste ich die Reihenfolge-Parameter aus
PHP. Auch die Umsetzung ohne Reguläre Ausdrücke hat mich erstaunt. Darum habe ich mir in
etwa 3 Stunden Arbeit selber sprintf() und vsprintf() aus PHP implementiert.
Später kahm dann noch die Formatierungsregeln etc. dazu.
Hier nun das Resultat.
Erweiterungen findet ihr unter [VBA] PrintF AddOns
Definitionen
Konstanten
Folgende Fehler-Codes sind definiert
Funktionen
sprintf()
Parst einen Pattern mit Werten 5).
Public Function sPrintF( _ ByVal iFormatString As String, _ ParamArray iParams() As Variant _ ) As String
- iFormatString Zu formatierender String
- Weitere Params die dazugehörigen Werte
vsprintf()
Parse einen String mit den Werten als Array 6).
Public Function vsPrintF( _ ByVal iFormatString As String, _ ByRef iParams() As Variant _ ) As String
- iFormatString Zu formatierender String
- iParams() die dazugehörigen Werte als Array
printF_UserDefinedDateFormat()
Mit dem Property printF_UserDefinedDateFormat können benuzerdefinierte FOrmate hinterlegt werden. Siehe Beispiel benutzerdefinierte_formate
Public Property Get printF_UserDefinedDateFormat(Optional ByVal iNumber As Integer = 0) As String
Patterns
Die Formatierungen sind verscheidene Patterns. Die meiste habe ich aus PHP übernommen, andere aus Java. Der Aufbau ist folgednermasen
%(Index)(Format)[Typ](Datum/ZeitFormat)
- Index Die Angabe, um welchen übergebenen Werteparameter es sich handelt. Die Angabe ist Optional. Mögliche Werte:
[Zahl]$Oder<. Bei eihner Zahl gefolgt von einem $ Zeichen ist die Nummer des Paramters gemeint. Beginnend bei 1. Sprich%2$sbedeutet, dass der zweite Parameter ausgegeben wird. Bei < wird derselbe Wert verarbeitet wie beim Pattern davor.%<snimmt also dieselbe Quelle wie der letzte Pattern vor ihm. - Format Bei Zahlen und texten können verschieden Formate mitgegeben werden
- Typ Mit einem Buchstaben wird definiert, um was für ein Datentyp es sich handelt
- Datum/ZeitFormat Wennd er Type T oder S ist, wird mit diesem Teil angegeben, was vom Datum angezeigt werden soll
Typ
Zahlen
c the argument is treated as an integer, and presented as the character with that ASCII value.
d the argument is treated as an integer, and presented as a (signed) decimal number.
e the argument is treated as scientific notation (e.g. 1.2e+2). The precision specifier stands for the number of digits after the decimal point
E like e but uses uppercase letter (e.g. 1.2E+2).
u the argument is treated as an integer, and presented as an unsigned decimal number.
f the argument is treated as a float, and presented as a floating-point number (locale aware).
g shorter of %e and %f.
G shorter of %E and %f.
o the argument is treated as an integer, and presented as an octal number.
Text
s the argument is treated as and presented as a string.
x the argument is treated as an integer and presented as a hexadecimal number (with lowercase letters).
X the argument is treated as an integer and presented as a hexadecimal number (with uppercase letters).
Datum/Zeit
T date/time Prefix for date and time conversion characters. See Date/Time Conversions.
t like T
S date/time Prefix for date and time conversion characters for MS Access SQL. See Date/Time Conversions.
Datum/ZeitFormat
Zeit Details
H Hour of the day for the 24-hour clock, formatted as two digits with a leading zero as necessary i.e. 00 - 23.
I Hour for the 12-hour clock, formatted as two digits with a leading zero as necessary, i.e. 01 - 12.
k Hour of the day for the 24-hour clock, i.e. 0 - 23.
l Hour for the 12-hour clock, i.e. 1 - 12.
M Minute within the hour formatted as two digits with a leading zero as necessary, i.e. 00 - 59.
S Seconds within the minute, formatted as two digits with a leading zero as necessary, i.e. 00 - 60 (“60” is a special value required to support leap seconds).
Datum Details
B Locale-specific full month name, e.g. “January”, “February”.
b Locale-specific abbreviated month name, e.g. “Jan”, “Feb”.
A Locale-specific full name of the day of the week, e.g. “Sunday”, “Monday”
a Locale-specific short name of the day of the week, e.g. “Sun”, “Mon”
C Four-digit year divided by 100, formatted as two digits with leading zero as necessary, i.e. 00 - 99
Y Year, formatted as at least four digits with leading zeros as necessary, e.g. 0092 equals 92 CE for the Gregorian calendar.
y Last two digits of the year, formatted with leading zeros as necessary, i.e. 00 - 99.
j Day of year, formatted as three digits with leading zeros as necessary, e.g. 001 - 366 for the Gregorian calendar.
m Month, formatted as two digits with leading zeros as necessary, i.e. 01 - 13.
d Day of month, formatted as two digits with leading zeros as necessary, i.e. 01 - 31
e Day of month, formatted as two digits, i.e. 1 - 31.
Datum/Zeit fixe Formate
R Time formatted for the 24-hour clock as “%tH:%tM”
T Time formatted for the 24-hour clock as “%tH:%tM:%tS”.
r Time formatted for the 12-hour clock as “%tI:%tM:%tS %Tp”. The location of the morning or afternoon marker ('%Tp') may be locale-dependent.
D Date formatted as “%tm/%td/%ty”.
f Datetime formated as “%tY-%t-%td_%H:%M:%S”
F ISO 8601 complete date formatted as “%tY-%tm-%td”.
Anwendungsbeispiele
Um ein wenig klar zu machen was die Funktion alles kann, hier mal einige Beispiele. Den Code zur Funktion befindet sich weiter unten.
Standartanwendung
Debug.Print sPrintF("Hallo %s", "Hans") Hallo Hans Debug.Print sPrintF("%s wiegt %f Kilo", "Hans", 76.5) Hans wiegt 76.5 Kilo Debug.Print sPrintF("%s wiegt %d Kilo", "Hans", 76.5) Hans wiegt 76 Kilo
Beispiel mit Reheinfolge
? sPrintF("%2$s wiegt %1$f Kilo", 76.5, "Hans") Hans wiegt 76.5 Kilo ? sPrintF("%1$s ist %1$s und %2$s ist %2$s", "Heute", "Morgen") Heute ist Heute und Morgen ist Morgen ? sPrintF("%s ist %<s und %s ist %<s", "Heute", "Morgen") Heute ist Heute und Morgen ist Morgen ? sprintf("Wir haben %d, ich wiederhole. Wir haben %<d Tage Zeit %d Millionen zu finden", 10, 20) Wir haben 10, ich wiederhole. Wir haben 10 Tage Zeit 20 Millionen zu finden ? sPrintF("%s, %<s, %<s! %3$s, %<s, %<s! %2$s, %<s, %<s! %s!", "Ha", "Ho", "Hi", "Yes") Ha, Ha, Ha! Hi, Hi, Hi! Ho, Ho, Ho! Yes!
Beispiele für dir Funktion vsprintf()
Dim params(1) As Variant params(0) = "Heute" params(1) = "Morgen" Debug.Print vsPrintF("%1$s ist %1$s und %2$s ist %2$s", params)
sprintf() mit Formatierungen
'Strings: debug.print sprintf("%1$s %1$'#6s %1$-'#6s %1$.3s %1$-.3s", "abcd") abcd ##abcd abcd## abc bcd 'Nummern: 'Float debug.print sprintf("%1$f %1$6f %1$-.1f %1$.3f %1$d", 123.45) 123.45 000123.45 +123.5 123.450 123 'Integer debug.print sprintf("%1$f %1$6f %1$-.1f %1$.3f %1$d", 123) 123 000123 +123.0 123.000 123
sprintf() mit Datum
Der Datumspattern ist Zweiteilig. Zuerst kommt ein Buchstabe um anzugegebe, dass es dsich um ein Datum/Zeit handelt und dann ein Buchstabe für das Format. Da sist nicht meine Erfindung, das übernehme ich so von Java (http://docs.oracle.com/javase/7/docs/api/java/util/Formatter.html). Einzig beim Einleitenden Buchstaben habe ich noch das S hinzugefügt, um den Output SQL Konform zu schreiben. Somit haben T oder S als Einleitender Buchstabe, gefolgt vom Format
? sprintf("Heute ist %TA der %<Te %<TB, %<TY", now) Heute ist Freitag der 29 Januar, 2016 ? sprintf("SELECT * FROM mytable WHERE in_date BETWEEN %2$SD AND %1$SD", now, now-10) SELECT * FROM mytable WHERE in_date BETWEEN #01/19/2016# AND #01/29/2016#
Benutzerdefinierte Formate
Es können bis zu 10 benutzerdefinierte Formate hinterlegt werden. Dazu kann man die Funktion printF_UserDefinedDateFormat verwenden. Die Formate können dann mittel U und dem Index abgerufenwerden
printF_UserDefinedDateFormat(0) = "HH.NN" printF_UserDefinedDateFormat(1) = "d. MMMM YYYY" debug.print sPrintF("%TU1 um %<TU0", now) 21. Oktober 2016 um 11.34
Text-Formatierungen (Zeilenumbrüche und Tabulator)
'Mit Zeilenumbruch \t und Tabulator \n debug.print sPrintF("%1$s\tist %1$s,\n%2$s\tist %2$s", "Heute", "Morgen") Heute ist Heute, Morgen ist Morgen 'Tabulator \t etc nicht parsen: den \ von \ mit einem \ markieren -> \\t debug.print sprintf("[\\t]\t%s", "ist ein Tabulator") [\t] ist ein Tabulator 'um nur diese Formatierungen umzuschreiben kann man auch ohne Paramter arbeiten debug.print sprintf("item:\tPunkt1") item: Punkt1
Code
- lib_printf.bas
Attribute VB_Name = "lib_printF" '------------------------------------------------------------------------------- 'File : lib_printF.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/doku.php/vba/functions/printf/index 'Environment : VBA XP - 2010 'Version : 2.7.1 'Name : PrintF 'Author : Stefan Erb (ERS) 'History : 04.04.2013 - 1.0.0 - ERS - Creation ' ... ' 03.03.2015 - 2.1.0 - ERS - NZ fr Excel eingefgt (Siehe #cont isAccess), eval("#" & value & "#") durch DateValue(value) ersetzt ' 29.01.2016 - 2.2.0 - ERS - Formate fr Datum hinzugefgt, < Als Positionszeichen hinzugefgt ' 26.09.2016 - 2.3.0 - ERS - Neues Datumsformat o Und O hinzugegt. Fehler behoben: Wenn in einem Pattern ein Datum und ein anderes Format war, funktioniert es nicht. ' Neues User-Datumsformat. Bis zu 10 Formate speicherbar und mittels %tu# abrufbar ' 30.10.2018 - 2.5.2 - ERS - Hotfix beim Ersetzen ' 15.11.2018 - 2.5.3 - ERS - Hotfox \t, \n, \r Am Anfang eines Patterns funktioniert jetzt ' 09.05.2019 - 2.6.0 - ERS - Neu q eingefhrt. Analog zu s aber als SQL-String. ?sprintf("abc=%1$'#6q", "abc") => abc='###abc' ' 10.05.2019 - 2.6.1 - ERS - Fehler bei formatierung von Integer korrigiert ' 06.02.2020 - 2.7.0 - ERS - \\ am Ende durch \ ersetzen. Jeder \ der als String verwendet werden soll, muss mit einem \ maskiert werden ' Null Parameter werden automatisch mit NZ() in empty umgewandelt '$f' ' ?sprintf("Null-Test: Zahl:'\\%f' Text:'\\%<s'", Null) -> Null-Test: Zahl:'\0' Text:'\' ' 13.02.2020 - 20701 - ERS - strReplace() durch replace() ersetzt. strReplace war von einer frheren Version drin ' 'Description : Aus der PHP-Doku: ' - An optional sign specifier that forces a sign (- or +) to be used on a number. By default, only the - sign is used on a number if it's negative. ' This specifier forces positive numbers to have the + sign attached as well, and was added in PHP 4.3.0. ' - An optional padding specifier that says what character will be used for padding the results to the right string size. This may be a space character or a 0 ' (zero character). The default is to pad with spaces. An alternate padding character can be specified by prefixing it with a single quote (') ' - An optional alignment specifier that says if the result should be left-justified or right-justified. The default is right-justified; a - character ' here will make it left-justified. ' - An optional number, a width specifier that says how many characters (minimum) this conversion should result in. ' - An optional precision specifier in the form of a period (`.') followed by an optional decimal digit string that says how many decimal digits ' should be displayed for floating-point numbers. When using this specifier on a string, it acts as a cutoff point, setting a maximum character ' limit to the string. ' ' A type specifier that says what type the argument data should be treated as. Possible types: ' % - a literal percent character. No argument is required. ' //b - the argument is treated as an integer, and presented as a binary number. ' c - the argument is treated as an integer, and presented as the character with that ASCII value. ' d - the argument is treated as an integer, and presented as a (signed) decimal number. ' e - the argument is treated as scientific notation (e.g. 1.2e+2). The precision specifier stands for the number of digits after the decimal point ' E - like %e but uses uppercase letter (e.g. 1.2E+2). ' u - the argument is treated as an integer, and presented as an unsigned decimal number. ' f - the argument is treated as a float, and presented as a floating-point number (locale aware). ' //F - the argument is treated as a float, and presented as a floating-point number (non-locale aware). Available since PHP 4.3.10 and PHP 5.0.3. ' g - shorter of %e and %f. ' G - shorter of %E and %f. ' o - the argument is treated as an integer, and presented as an octal number. ' s - the argument is treated as and presented as a string. ' q - the argument is treated as and presented as a string in sql-form: 'string' ' x - the argument is treated as an integer and presented as a hexadecimal number (with lowercase letters). ' X - the argument is treated as an integer and presented as a hexadecimal number (with uppercase letters). ' t, T - date/time Prefix for date and time conversion characters. See Date/Time Conversions. ' S - date/time Prefix for date and time conversion characters for MS Access SQL. See Date/Time Conversions. ' ' Datumsformate: ' http://docs.oracle.com/javase/7/docs/api/java/util/Formatter.html ' f ' The following conversion characters are used for formatting times: ' H Hour of the day for the 24-hour clock, formatted as two digits with a leading zero as necessary i.e. 00 - 23. ' I Hour for the 12-hour clock, formatted as two digits with a leading zero as necessary, i.e. 01 - 12. ' k Hour of the day for the 24-hour clock, i.e. 0 - 23. ' i Hour for the 12-hour clock, i.e. 1 - 12. ' M Minute within the hour formatted as two digits with a leading zero as necessary, i.e. 00 - 59. ' S Seconds within the minute, formatted as two digits with a leading zero as necessary, i.e. 00 - 60 ("60" is a special value required to support leap seconds). ' The following conversion characters are used for formatting dates: ' B Locale-specific full month name, e.g. "January", "February". ' b Locale-specific abbreviated month name, e.g. "Jan", "Feb". ' A Locale-specific full name of the day of the week, e.g. "Sunday", "Monday" ' a Locale-specific short name of the day of the week, e.g. "Sun", "Mon" ' C Four-digit year divided by 100, formatted as two digits with leading zero as necessary, i.e. 00 - 99 ' Y Year, formatted as at least four digits with leading zeros as necessary, e.g. 0092 equals 92 CE for the Gregorian calendar. ' y Last two digits of the year, formatted with leading zeros as necessary, i.e. 00 - 99. ' j Day of year, formatted as three digits with leading zeros as necessary, e.g. 001 - 366 for the Gregorian calendar. ' m Month, formatted as two digits with leading zeros as necessary, i.e. 01 - 13. ' d Day of month, formatted as two digits with leading zeros as necessary, i.e. 01 - 31 ' e Day of month, formatted as two digits, i.e. 1 - 31. ' The following conversion characters are used for formatting common date/time compositions. ' R Time formatted for the 24-hour clock as "%tH:%tM" ' T Time formatted for the 24-hour clock as "%tH:%tM:%tS". ' r Time formatted for the 12-hour clock as "%tI:%tM:%tS %Tp". The location of the morning or afternoon marker ('%Tp') may be locale-dependent. ' D Date formatted as "#%tm/%td/%ty#". ' t DateTime formatted as "%tm/%td/%ty %tH:%tM:%tS". ' F ISO 8601 complete date formatted as "%tY-%tm-%td". ' f order by Datetie for sortable Date %tY-%t-%td_%H:%M:%S ' L Date in Local "Long Date" Format ' l Date in Local "Short Date" Format ' o order by Date for sortable Date %tY%t%td ' O order by Datetime for sortable Date %tY%t%td_%H%M%S ' u User Format -> %u1. Set the Userformat with the public property printF_UserDefinedDateFormat(1) = "DD.MM" ' ' Zustzlich noch die Formatierungen analog http://www.freevbcode.com/ShowCode.asp?ID=5014 ' Um einen davon nicht zu parsen einfach mit einem \ marieren: '\\t' wird nicht zu Tabulator sondern zu '\t' geparst ' \n Newline (Line Feed) ' \r Carriage Return ' \t Horizontal Tab '------------------------------------------------------------------------------- '------------------------------------------------------------------------------- ' -- ! SETTINGS ! '------------------------------------------------------------------------------- 'In Excel funktionieren Events nicht. Auch der NZ() gibt es dort nicht. 'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts dazu keine Systemvariable #Const isAccess = True Option Explicit '----------------------------------------- '--- Public members '----------------------------------------- 'Error: Zu wenige Werte wurden bergeben Public Const ERR_INSUFFICIENT_PARAMS = vbObjectError - 10 'Es wird keine Zahl geliefert wo eine erwartet wird Public Const ERR_NOT_NUMBER = vbObjectError - 11 'Das Format ist ungltig Public Const ERR_INVALID_FORMAT = vbObjectError - 12 '----------------------------------------- '--- Private members '----------------------------------------- 'Die Auflistung der Submatches des geparsten Elements (Pattern D_ELEMENT_PATTERN) Private Enum eSubElements emSubType1 = 0 emCount emSubType2 emType1 emType2 emFormat emIndex emPrefPos End Enum 'Die Auflistung der Submatches des geparsten Formates (Pattern C_FORMAT_PATTERN) Private Enum eSubFormat emWithSign = 0 emFillZeroChar emFillChar emFillLength emInternalDecimalPlaces End Enum 'Die Sammlung der Infos aus dem Pattern und der Typendefinition Private Type tParts paramIndex As Integer types As String subTypeS As String count As Integer 'Ein Counter valueV As Variant 'Value als Variant, Also in Der Rohform aus dem Input values As String 'Formatierter Value als String format As String 'Das Format typeDef As String 'Typendefinition End Type 'Infos aus dem Format Private Type tFormat withSgn As Boolean 'Flag: das Vorzeigen immer angezeigt werden muss sgn As String 'Vorzeichen hasInternalDecimalPlaces As Boolean 'Flag: hat Fixe nachkommastellen internalDecimalPlaces As Integer 'Fixe Nachkommastellen fillChar As String 'Fllzeichen hasFillLength As Boolean 'Flag: Hat fixe Vorkommalnge fillLength As Integer 'Fixe Vorkommalnge End Type Private Enum eTypeDef eString eNumber eDateTime eSpezial End Enum Private Enum sysLocale LOCALE_IFIRSTDAYOFWEEK = &H100C 'first day of week specifier 0=Mon, 6=Sun https://msdn.microsoft.com/en-us/library/windows/desktop/dd373771%28v=vs.85%29.aspx LOCALE_IFIRSTWEEKOFYEAR = &H100D 'first week of year specifier 0=direct, 1=Full, 2=4days https://msdn.microsoft.com/en-us/library/windows/desktop/dd373772%28v=vs.85%29.aspx LOCALE_SSHORTDATE = &H1F '31: short date format string End Enum Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long Private Declare Function getLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long Private userDateFormat(0 To 9) As String '----------------------------------------- '--- Public Methodes '----------------------------------------- '/** ' * Parse einen String mit Werten ' * @param <String> Zu formatierender String ' * @param <Variant>* die dazugehrigen Werte ' * @return <String> ' */ Public Function sPrintF(ByVal iFormatString As String, ParamArray iParams() As Variant) As String On Error GoTo Err_Handler: Err.Source = "sPrintF" If UBound(iParams) = -1 Then sPrintF = replaceFormat(iFormatString) Else sPrintF = vsPrintF(iFormatString, CVar(iParams)) End If Exit_Handler: On Error Resume Next Exit Function Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Function '/** ' * Parse einen String mit den Werten als Array. ' * @param <String> Zu formatierender String ' * @param Array<Variant> die dazugehrigen Werte ' * @return <String> ' */ Public Function vsPrintF(ByVal iFormatString As String, ByRef iParams As Variant) As String On Error GoTo Err_Handler: Err.Source = "vsPrintF" Dim params As Variant: params = IIf(IsArray(iParams), iParams, Array(iParams)) 'Formatedefinitionen /t /n etc ausfhren 'Der String muss nachher umgedreht werden, da VBA object kein (?>!..) kennt vsPrintF = replaceFormat(iFormatString) 'Wenn keine Parameters angegeben sind, dann beenden If UBound(params) = -1 Then Resume Exit_Handler 'String parsen ' vsPrintF = evalWithRx(rxDTElement, vsPrintF, params) vsPrintF = evalWithRx(rxElement, vsPrintF, params) 'Maskierte \ zurcksetzen vsPrintF = replace(vsPrintF, "\\", "\") Exit_Handler: On Error Resume Next Exit Function Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Function '----------------------------------------- '--- Public Properties '----------------------------------------- '/** ' * Ein Userdefiniertes Datumsformat ' * @param Integer Nummer des Formates. 0-9 mglich ' * @return String Datumsformat ' */ Public Property Get printF_UserDefinedDateFormat(Optional ByVal iNumber As Integer = 0) As String iNumber = IIf(iNumber > 9, 9, iNumber) iNumber = IIf(iNumber < 0, 0, iNumber) printF_UserDefinedDateFormat = IIf(userDateFormat(iNumber) = Empty, "Short Date", userDateFormat(iNumber)) End Property Public Property Let printF_UserDefinedDateFormat(ByVal iNumber As Integer, ByVal iDateFormat As String) iNumber = IIf(iNumber > 9, 9, iNumber) iNumber = IIf(iNumber < 0, 0, iNumber) userDateFormat(iNumber) = iDateFormat End Property '----------------------------------------- '--- Private Properties/Cache '----------------------------------------- '/** ' * object um die einzelnen Elemente aus dem Pattern zu extrahieren ' * 0: SubType ' * 1: Type ' * 2: Type ' * 3: Count ' * 4: Type ' * 5: Format ' * 6: Item Nummer ' * 7: Verweis auf vorhergehende Position ' * @return object ' */ Private Property Get rxElement() As Object Static rx As Object If rx Is Nothing Then Set rx = cRx("/(?:(?:([HIikLlMSLNpzZsQBbhAaCYyjmdeRTtrDFfPoO])|(\d)([u]))([tTS])|([sqcdfuoxXeEgG]))([\d-\.'#]*)(?:\$(\d+)|(<))?%(?!\\(?!\\))/gm") Set rxElement = rx End Property Private Property Get rxNonElement() As Object Static rx As Object If rx Is Nothing Then Set rx = cRx("/((?:(?:[HIikLlMSLNpzZsQBbhAaCYyjmdeRTtrDFfPoO]|\d[u])[tTS]|[sqcdfuoxXeEgG])[\d-\.'#]*(?:\$\d+|<)?%)(?:\\(?!\\))/gm") Set rxNonElement = rx End Property 'Private Property Get rxElement() As Object ' Static rx As Object ' If rx Is Nothing Then Set rx = cRx("/()([scdfuoxXeEgG])([\d-\.'#]*)(?:\$(\d+)|(<)|)%(?!\\)/gm") ' Set rxElement = rx 'End Property ' 'Private Property Get rxDTElement() As Object ' Static rx As Object ' If rx Is Nothing Then Set rx = cRx("/([HIikLlMSLNpzZsQBbhAaCYyjmdeRTrDFPoO])([tTS])([\d-\.'#]*)(?:\$(\d+)|(<)|)%(?!\\)/gm") ' Set rxDTElement = rx 'End Property '/** ' * object um die Formate zu analysieren ' * emWithSign = 0 ' * emFillZeroChar ' * emFillChar ' * emFillLength ' * emInternalDecimalPlaces ' * @return object ' */ Private Property Get rxFormat() As Object Static rx As Object If rx Is Nothing Then Set rx = cRx("/([-+]?)(?:(0)|'(.)|)([1-9]\d*|)(?:\.([0-9]+)|)/gm") Set rxFormat = rx End Property '/** ' * Typendefinition ' * @return Dictionary ' */ Private Property Get typeDefs() Static pCacheTypeDefs As Object If pCacheTypeDefs Is Nothing Then Set pCacheTypeDefs = CreateObject("scripting.Dictionary") With pCacheTypeDefs .RemoveAll 'Die verschiedenen Typendefinitionen laden .add "s", eString 's - the argument is treated as and presented as a string. .add "q", eString 'q - the argument is treated as and presented as a string. .add "d", eNumber 'd - the argument is treated as an integer, and presented as a (signed) decimal number. .add "f", eNumber 'f - the argument is treated as a float, and presented as a floating-point number (locale aware). .add "u", eNumber 'u - the argument is treated as an integer, and presented as an unsigned decimal number. .add "c", eSpezial 'c - the argument is treated as an integer, and presented as the character with that ASCII value. .add "o", eSpezial 'o - the argument is treated as an integer, and presented as an octal number. .add "x", eSpezial 'x - the argument is treated as an integer and presented as a hexadecimal number (with lowercase letters). .add "X", eSpezial 'X - the argument is treated as an integer and presented as a hexadecimal number (with uppercase letters). .add "e", eSpezial 'e - the argument is treated as scientific notation (e.g. 1.2e+2). The precision specifier stands for the number of digits after the decimal point .add "E", eSpezial 'E - like %e but uses uppercase letter (e.g. 1.2E+2). .add "g", eSpezial 'g - shorter of %e and %f. .add "G", eSpezial 'G - shorter of %E and %f. .add "t", eDateTime .add "T", eDateTime .add "S", eDateTime End With End If Set typeDefs = pCacheTypeDefs End Property '/** ' * die object um die Formatierungen (\t, \n etc) zu handeln ' * @return Dictionary(object => ReplaceString) ' */ Public Property Get formatDefs() As Object Static pCacheFormatDefs As Object If pCacheFormatDefs Is Nothing Then Set pCacheFormatDefs = CreateObject("scripting.Dictionary") pCacheFormatDefs.add cRx("/(.*[^\\]|^)\\n(.*)/m"), "$1" & vbLf & "$2" '\n Newline (Line Feed) pCacheFormatDefs.add cRx("/(.*[^\\]|^)\\r(.*)/m"), "$1" & vbCr & "$2" '\r Carriage Return pCacheFormatDefs.add cRx("/(.*[^\\]|^)\\t(.*)/m"), "$1" & vbTab & "$2" '\t Horizontal Tab End If Set formatDefs = pCacheFormatDefs End Property '----------------------------------------- '--- Private Methodes '----------------------------------------- '/** ' * Wertet den String anhand eines RegeExp aus ' * @param RegExp ' * @param String ' * @param Array<Variant> ' * @return String ' */ Private Function evalWithRx(ByRef irx As Object, ByVal iString As String, ByRef iParams As Variant) As String On Error GoTo Err_Handler: Err.Source = "evalWithRx" evalWithRx = StrReverse(iString) If Not irx.test(evalWithRx) Then GoTo Exit_Handler Dim matches As Object: Set matches = irx.execute(evalWithRx) Dim lEof As Long: lEof = matches.count - 1 Dim parts() As tParts: ReDim parts(lEof) Dim delta As Long Dim i As Integer: For i = lEof To 0 Step -1 Dim position As Integer: position = (lEof - i) Dim ma As Object: Set ma = matches.item(i) With parts(i) 'Werte aus dem Pattern auslesen 'Der Index aus dem Pattern oder die Position im String 'Falls es sich um ein < Handelt, den vorherigen paramIndex verwenden, ausser es ist der Erste If ma.subMatches(emPrefPos) = "<" And i < lEof Then .paramIndex = parts(i + 1).paramIndex delta = delta - 1 'Keine eindeutige Position angegeben ElseIf ma.subMatches(emIndex) = Empty Then .paramIndex = position + delta 'Position aus dem Pattern bernehmen Else .paramIndex = ma.subMatches(emIndex) - 1 End If 'Formatdefinitionen aus dem Pattern .format = StrReverse(NZ(ma.subMatches(emFormat))) .types = ma.subMatches(emType1) & ma.subMatches(emType2) .subTypeS = ma.subMatches(emSubType1) & ma.subMatches(emSubType2) .count = CInt(NZ(ma.subMatches(emCount))) 'Werte der Typendefinitione bernehmen .typeDef = typeDefs(.types) 'Prfen ob zu dem ermittelten Index auch ein Parameterwert exisitiert If .paramIndex > UBound(iParams) Then Call Err.Raise(ERR_INSUFFICIENT_PARAMS, , "Not enough values fr (v)sprintf(). ") 'unformatierten Wert aus den Parametern auslsen .valueV = NZ(iParams(.paramIndex)) 'Parsen und Formatieren. Select Case .typeDef Case eSpezial: Call parseSpezial(parts(i)) Case eDateTime: Call parseDateTime(parts(i)) Case eNumber: Call parseNumber(parts(i)) Case eString: Call parseString(parts(i)) End Select End With Next i Dim rx As Object: Set rx = cRx("/" & irx.pattern & "/m") i = 0 Do While rx.test(evalWithRx) evalWithRx = rx.replace(evalWithRx, StrReverse(parts(i).values)) i = i + 1 Loop 'Maskierung bei maskierten Pattern entfernen evalWithRx = rxNonElement.replace(evalWithRx, "$1") Exit_Handler: On Error Resume Next evalWithRx = StrReverse(evalWithRx) Set ma = Nothing Set matches = Nothing Exit Function Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Function '/** ' * Parst Formatierungen wie \n, \t etc ' * @param <String> Zu formatierender String ' * @return <String> ' */ Private Function replaceFormat(ByVal iFormatString As String) As String On Error GoTo Err_Handler: Err.Source = "replaceFormat" replaceFormat = iFormatString Dim rx As Variant: For Each rx In formatDefs Do While rx.test(replaceFormat) replaceFormat = rx.replace(replaceFormat, formatDefs(rx)) Loop Next Exit_Handler: On Error Resume Next Exit Function Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Function '/* ' * Nur das preFormat wird ausgefhrt. Der format-Part des Patterns wird ignoriert ' * @param <tParts> ' */ Private Sub parseSpezial(ByRef ioParts As tParts) On Error GoTo Err_Handler: Err.Source = "parseSpezial" With ioParts Select Case .types Case "c": .valueV = Chr(CInt(.valueV)) Case "o": .valueV = Oct(.valueV) Case "x": .valueV = LCase(Hex(.valueV)) Case "X": .valueV = UCase(Hex(.valueV)) Case "e": .valueV = LCase(format(.valueV, "Scientific")) Case "E": .valueV = UCase(format(.valueV, "Scientific")) Case "g": .valueV = IIf(Len(".ValueV") <= Len(format(.valueV, "Scientific")), CDbl(.valueV), LCase(format(.valueV, "Scientific"))) Case "G": .valueV = IIf(Len(".ValueV") <= Len(format(.valueV, "Scientific")), CDbl(.valueV), UCase(format(.valueV, "Scientific"))) End Select End With Exit_Handler: On Error Resume Next Exit Sub Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Sub '/* ' * Parse a Number ' * @param <tParts> ' */ Private Sub parseNumber(ByRef ioParts As tParts) On Error GoTo Err_Handler: Err.Source = "parseNumber" With ioParts If Not IsNumeric(.valueV) Then Call Err.Raise(ERR_NOT_NUMBER, , "Parameter is not a Number") Select Case .types Case "d": .valueV = CLng(.valueV) Case "f": .valueV = CDbl(.valueV) Case "u": .valueV = Abs(CInt(.valueV)) End Select .values = parseNumberFormat(.format, .valueV) End With Exit_Handler: On Error Resume Next Exit Sub Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Sub '/** ' * Formatiert eine Nummer ' * @param String ' * @param Variant ' * @return String ' */ Private Function parseNumberFormat(ByVal iFormat As String, ByVal iValueV As Variant) As String On Error GoTo Err_Handler: Err.Source = "parseNumberFormat" parseNumberFormat = CStr(iValueV) If iFormat = vbNullString Then Exit Function 'Formatdetails auselsen Dim fd As tFormat: fd = parseFormat(iFormat, 0) Dim formats As String 'Mit 0 auffllen formats = "0" If fd.hasFillLength Then formats = str_repeat("0", fd.fillLength) 'Dezmalzeichen If fd.hasInternalDecimalPlaces Then If fd.internalDecimalPlaces > 0 Then formats = formats & "." & str_repeat("0", fd.internalDecimalPlaces) Else If iValueV <> Fix(iValueV) Then formats = formats & "." & str_repeat("#", Len(iValueV - Fix(iValueV))) End If End If 'Vorzeichen If fd.withSgn Then formats = "+" & formats & ";-" & formats parseNumberFormat = format(iValueV, formats) Exit_Handler: On Error Resume Next Exit Function Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Function '/* ' * Parse a String ' * @param <tParts> ' */ Private Sub parseString(ByRef ioParts As tParts) On Error GoTo Err_Handler: Err.Source = "parseString" With ioParts 'ERS: 08.12.2014: Keine Ahnung warum ' maskiert werden sollten ' '-Zeichen im Text markieren ' .valueV = Replace(CStr(.valueV), "'", "''") 'Wenn kein Format definiert ist, einfach die Variable un .values = CStr(.valueV) If Not .format = vbNullString Then 'Formatdetails auselsen. Die Items von fd haben die Namen von der Nummerformatierung Dim fd As tFormat: fd = parseFormat(.format, " ") 'Wenn ien Vorzeichen gesetzt ist, das ganez Rechtbndig nehmen 'An optional alignment specifier that says if the result should be left-justified or right-justified. The default is right-justified; a - character 'here will make it left-justified. If fd.sgn = "-" Then If fd.hasFillLength Then .values = rPad(.values, fd.fillChar, fd.fillLength) End If If fd.hasInternalDecimalPlaces Then .values = Right(.values, fd.internalDecimalPlaces) End If Else If fd.hasFillLength Then .values = lPad(.values, fd.fillChar, fd.fillLength) End If If fd.hasInternalDecimalPlaces Then .values = Left(.values, fd.internalDecimalPlaces) End If End If End If If .types = "q" Then .values = "'" & .values & "'" End With Exit_Handler: On Error Resume Next Exit Sub Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Sub ' The following conversion characters are used for formatting times: ' 'H' Hour of the day for the 24-hour clock, formatted as two digits with a leading zero as necessary i.e. 00 - 23. ' 'I' Hour for the 12-hour clock, formatted as two digits with a leading zero as necessary, i.e. 01 - 12. ' 'k' Hour of the day for the 24-hour clock, i.e. 0 - 23. ' 'i' Hour for the 12-hour clock, i.e. 1 - 12. ' 'M' Minute within the hour formatted as two digits with a leading zero as necessary, i.e. 00 - 59. ' 'S' Seconds within the minute, formatted as two digits with a leading zero as necessary, i.e. 00 - 60 ("60" is a special value required to support leap seconds). '- 'L' Millisecond within the second formatted as three digits with leading zeros as necessary, i.e. 000 - 999. '- 'N' Nanosecond within the second, formatted as nine digits with leading zeros as necessary, i.e. 000000000 - 999999999. '- 'p' Locale-specific morning or afternoon marker in lower case, e.g."am" or "pm". Use of the conversion prefix 'T' forces this output to upper case. '- 'z' RFC 822 style numeric time zone offset from GMT, e.g. -0800. This value will be adjusted as necessary for Daylight Saving Time. For long, Long, and Date the time zone used is the default time zone for this instance of the Java virtual machine. '- 'Z' A string representing the abbreviation for the time zone. This value will be adjusted as necessary for Daylight Saving Time. For long, Long, and Date the time zone used is the default time zone for this instance of the Java virtual machine. The Formatter's locale will supersede the locale of the argument (if any). '- 's' Seconds since the beginning of the epoch starting at 1 January 1970 00:00:00 UTC, i.e. Long.MIN_VALUE/1000 to Long.MAX_VALUE/1000. '- 'Q' Milliseconds since the beginning of the epoch starting at 1 January 1970 00:00:00 UTC, i.e. Long.MIN_VALUE to Long.MAX_VALUE. ' ' The following conversion characters are used for formatting dates: ' 'B' Locale-specific full month name, e.g. "January", "February". ' 'b' Locale-specific abbreviated month name, e.g. "Jan", "Feb". '- 'h' Same as 'b'. ' 'A' Locale-specific full name of the day of the week, e.g. "Sunday", "Monday" ' 'a' Locale-specific short name of the day of the week, e.g. "Sun", "Mon" ' 'C' Four-digit year divided by 100, formatted as two digits with leading zero as necessary, i.e. 00 - 99 ' 'Y' Year, formatted as at least four digits with leading zeros as necessary, e.g. 0092 equals 92 CE for the Gregorian calendar. ' 'y' Last two digits of the year, formatted with leading zeros as necessary, i.e. 00 - 99. ' 'j' Day of year, formatted as three digits with leading zeros as necessary, e.g. 001 - 366 for the Gregorian calendar. ' 'm' Month, formatted as two digits with leading zeros as necessary, i.e. 01 - 13. ' 'd' Day of month, formatted as two digits with leading zeros as necessary, i.e. 01 - 31 ' 'e' Day of month, formatted as two digits, i.e. 1 - 31. ' ' The following conversion characters are used for formatting common date/time compositions. ' 'R' Time formatted for the 24-hour clock as "%tH:%tM" ' 'T' Time formatted for the 24-hour clock as "%tH:%tM:%tS". ' 'r' Time formatted for the 12-hour clock as "%tI:%tM:%tS %Tp". The location of the morning or afternoon marker ('%Tp') may be locale-dependent. ' 'D' Date formatted as "%tm/%td/%ty". ' 't' DateTime formatted as "%tm/%td/%ty %tH:%tM:%tS". ' 'F' ISO 8601 complete date formatted as "%tY-%tm-%td". ' 'f' order by Datetie for sortable Date %tY-%t-%td_%H:%M:%S ' 'L' Date in Local "Long Date" Format ' 'l' Date in Local "Short Date" Format '- 'c' Date and time formatted as "%ta %tb %td %tT %tZ %tY", e.g. "Sun Jul 20 16:17:00 EDT 1969". ' 'o' order by Date for sortable Date %tY%t%td ' 'O' order by Datetie for sortable Date %tY%t%td_%H%M%S ' 'u' User Format -> %u0 '/* ' * Parse a String ' * @param <tParts> ' */ Private Sub parseDateTime(ByRef ioParts As tParts) On Error GoTo Err_Handler: Err.Source = "parseDateTime" Select Case ioParts.subTypeS Case "H": ioParts.values = format(ioParts.valueV, "HH") Case "I": ioParts.values = format(ioParts.valueV, "HHAMPM") Case "k": ioParts.values = format(ioParts.valueV, "H") Case "i": ioParts.values = format(ioParts.valueV, "HAMPM") Case "M": ioParts.values = format(ioParts.valueV, "NN") Case "S": ioParts.values = format(ioParts.valueV, "SS") Case "P": ioParts.values = format(ioParts.valueV, "AM/PM") Case "B": ioParts.values = format(ioParts.valueV, "MMMM") Case "b": ioParts.values = format(ioParts.valueV, "MMM") Case "A": ioParts.values = format(ioParts.valueV, "DDDD") Case "a": ioParts.values = format(ioParts.valueV, "DDD") Case "C": ioParts.values = CStr(year(ioParts.valueV) \ 100) Case "Y": ioParts.values = format(ioParts.valueV, "YYYY") Case "Y": ioParts.values = format(ioParts.valueV, "YY") Case "j": ioParts.values = format(format(ioParts.valueV, "Y"), "000") Case "m": ioParts.values = format(ioParts.valueV, "MM") Case "d": ioParts.values = format(ioParts.valueV, "DD") Case "e": ioParts.values = format(ioParts.valueV, "D") Case "R": ioParts.values = format(ioParts.valueV, "HH:NN") Case "T": ioParts.values = format(ioParts.valueV, "HH:NN:SS") Case "r": ioParts.values = format(ioParts.valueV, "HH:NN:SS AM/PM") Case "D": ioParts.values = format(ioParts.valueV, "MM\/DD\/YYYY") Case "t": ioParts.values = format(ioParts.valueV, "MM\/DD\/YYYY HH:NN:SS") Case "F": ioParts.values = format(ioParts.valueV, "YYYY-MM-DD") Case "f": ioParts.values = format(ioParts.valueV, "YYYY-MM-DD HH:NN:SS") Case "L": ioParts.values = format(ioParts.valueV, "Long Date") Case "l": ioParts.values = format(ioParts.valueV, "Short Date") Case "O": ioParts.values = format(ioParts.valueV, "YYYYMMDD_HHNNSS") Case "o": ioParts.values = format(ioParts.valueV, "YYYYMMDD") Case "u": ioParts.values = format(ioParts.valueV, printF_UserDefinedDateFormat) End Select 'Spezialfall SQL If ioParts.types = "S" Then Select Case ioParts.subTypeS Case "R", "T", "t", "D", "F", "f", "r": ioParts.values = "#" & ioParts.values & "#" Case "B", "b", "A", "a": ioParts.values = "'" & ioParts.values & "'" End Select End If Exit_Handler: On Error Resume Next Exit Sub Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Sub '/** ' * Parst den Format-Teil des Patterns ' * @param <String> Formatteil ' * @param <Variant> Standart-Fllzeichen ' * @return <tFormat> ' */ Private Function parseFormat(ByVal iFormat As String, ByVal iDefaultFillChar As Variant) As tFormat On Error GoTo Err_Handler: Err.Source = "parseFormat" If Not rxFormat.test(iFormat) Then Call Err.Raise(ERR_INVALID_FORMAT, , "Wrong Format '" & iFormat & "'") 'Format parsen Dim matches As Object: Set matches = rxFormat.execute(iFormat) Dim subMatches As Object: Set subMatches = matches.item(0).subMatches 'Die einzelnen Teile auslesen und auswerten With parseFormat 'Fllzeichen ermitteln .fillChar = subMatches(emFillZeroChar) If .fillChar = Empty Then .fillChar = subMatches(emFillChar) If .fillChar = Empty Then .fillChar = iDefaultFillChar 'Fllnge .hasFillLength = subMatches(emFillLength) <> Empty If .hasFillLength Then .fillLength = CInt(subMatches(emFillLength)) 'Nachkommastellen .hasInternalDecimalPlaces = subMatches(emInternalDecimalPlaces) <> Empty If .hasInternalDecimalPlaces Then .internalDecimalPlaces = CInt(subMatches(emInternalDecimalPlaces)) 'Vorzeichen (bei String, Links-Rechts Bndig) .withSgn = subMatches(emWithSign) <> Empty 'Das Vorzeichen selber wird so nur beim String verwendet .sgn = IIf(.withSgn, subMatches(emWithSign), "+") End With Exit_Handler: On Error Resume Next Set subMatches = Nothing Set matches = Nothing Exit Function Err_Handler: Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext) Resume Exit_Handler Resume End Function '----------------------------------------- '--- Verwendete allgemeine Funktionen '----------------------------------------- '----------------------------------------- ' cDict V 2.1.0 '----------------------------------------- '/** ' * Wandelt verschiedene Formate in ein Dictionary um ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdict ' * @param ParamArray ' * @return Dictionary ' */ Private Function cDict(ParamArray iItems() As Variant) As Object Set cDict = CreateObject("scripting.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 'Prfen 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 Not IsArray(item) And Not IsObject(item) Then If 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 = dateValue(value) 'eval("#" & value & "#") Case Empty: value = CDec(value) Case Else: value = cRx("/\\(['""])/g").replace(value, "$1") End Select If Not cDict.exists(key) Then cDict.add key, value Next k Else GoTo default 'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt bergeben wird. Darum konnte der Test nicht im ElseIf durchgefhrt werden. End If 'Alles andere geht in ein WertePaar. ElseIf i = 0 Or isList Then default: 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 zurck, 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 zurck ' * @param Variant Variable, di abgefllt 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 object-Cache um ein Set-String zu zerlegen ' * @return object ' */ Private Property Get rxSetString() As Object Static rxCachedSetString As Object If rxCachedSetString Is Nothing Then Set rxCachedSetString = CreateObject("VBScript.RegExp") rxCachedSetString.Global = True rxCachedSetString.pattern = "(?:(['""#])(?!\\)(.+?)\1(?!\\)|([0-9\.]+?))\s*(?:>=|[:=])\s*(?:\]([^\[]+)\[|(['""])(?!\\)(.+?)\5(?!\\)|(\w+))" End If Set rxSetString = rxCachedSetString End Property '------------------------------------------------------------------------------- '-- cRx() '------------------------------------------------------------------------------- '/** ' * Dies ist die Minimalversion von cRegExp ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version ' * mgliche Delemiter: @&!/~#=\| ' * mgliche 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 object-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 'http://support.microsoft.com/kb/96458 '===================================================================== 'The following function will left pad a string with a specified 'character. It accepts a base string which is to be left padded with 'characters, a character to be used as the pad character, and a 'length which specifies the total length of the padded result. '===================================================================== Private Function lPad(ByVal MyValue$, ByVal MyPadCharacter$, ByVal MyPaddedLength%) Dim x As Integer Dim PadLength As Integer PadLength = MyPaddedLength - Len(MyValue) Dim padString As String For x = 1 To PadLength padString = padString & MyPadCharacter Next lPad = padString + MyValue End Function '===================================================================== 'The following function will right pad a string with a specified 'character. It accepts a base string which is to be right padded with 'characters, a character to be used as the pad character, and a 'length which specifies the total length of the padded result. '===================================================================== Private Function rPad(ByVal MyValue$, ByVal MyPadCharacter$, ByVal MyPaddedLength%) Dim x As Integer Dim PadLength As Integer PadLength = MyPaddedLength - Len(MyValue) Dim padString As String For x = 1 To PadLength padString = MyPadCharacter & padString Next rPad = MyValue + padString End Function '/** ' * Wiederholt einen String ' * http://wiki.yaslaw.info/wikka/vbvbaStringFunctions ' * @param String zu wiederholender String ' * @param Integer Anzahl weiderholungen ' * @return String Resultat ' */ Private Function str_repeat(ByVal str As String, ByVal multiplier As Integer) As String Dim i As Integer For i = 1 To multiplier str_repeat = str_repeat & str Next i End Function #If Not isAccess Then '/** ' * Wandelt NULL in EMpty oder einen Defaultwert ' * @param Variant ' * @param Variant ' * @return Variant ' */ Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant If IsNull(iValue) Then NZ = iDefault Else NZ = iValue End If End Function #End If
vba/functions/printf/index.1477042938.txt.gz · Last modified: 21.10.2016 11:42:18 by yaslaw
Except where otherwise noted, content on this wiki is licensed under the following license: GNU Free Documentation License 1.3
