Key Points
- Each
Caseblock implements formatting functionality for a specific format specifier. Gotostatements indicate the function wants to be broken down into several smaller functions.- Local variables such as
alignmentSpecifier,alignmentPadding,precisionString,precisionSpecifier,formatSpecifierand all others, could all be eliminated if there was a concept of a "FormatSpecifier" object that held all these values. - Bringing in
escapeHexand the C# hex specifier is a hack easily made useless by correctly encapsulating each format specifier. escapescollection gets rebuilt every time the function is called, which is inefficient; valid escape sequences don't change from one call to the next.- ASCII (hex & octal) escapes both desperately want to be part of that collection.
- Replacing
\\with ASCII code for Esc works nicely to get backslashes escaped.
Rewrite
Here's the refactored module-level function - it assumesuses a Private helper As New StringHelper is, declared at module level ("declarations" section):
The EscapeSequence class was annoyingly leaving out ASCII escapes, so I tackled this first:
Escape Sequences
The `EscapeSequence` class was annoyingly leaving out ASCII escapes, so I tackled this first:Private Type tEscapeSequence
EscapeString As String
ReplacementString As String
IsAsciiCharacter As Boolean
AsciiBase As AsciiEscapeBase
End Type
Public Enum AsciiEscapeBase
Octal
Hexadecimal
End Enum
Private this As tEscapeSequence
Option Explicit
Public Property Get EscapeString() As String
EscapeString = this.EscapeString
End Property
Friend Property Let EscapeString(value As String)
this.EscapeString = value
End Property
Public Property Get ReplacementString() As String
ReplacementString = this.ReplacementString
End Property
Friend Property Let ReplacementString(value As String)
this.ReplacementString = value
End Property
Public Property Get IsAsciiCharacter() As Boolean
IsAsciiCharacter = this.IsAsciiCharacter
End Property
Friend Property Let IsAsciiCharacter(value As Boolean)
this.IsAsciiCharacter = value
End Property
Public Property Get AsciiBase() As AsciiEscapeBase
AsciiBase = this.AsciiBase
End Property
Friend Property Let AsciiBase(value As AsciiEscapeBase)
this.AsciiBase = value
End Property
The factory Create function was added two optional parameters; one to specify whether the escape sequence indicates an ASCII replacement escape, the other to specify the base (an enum) of the digits representing the ASCII code:
Private Type tEscapeSequence
EscapeString As String
ReplacementString As String
IsAsciiCharacter As Boolean
AsciiBase As AsciiEscapeBase
End Type
Public Enum AsciiEscapeBase
Octal
Hexadecimal
End Enum
Private this As tEscapeSequence
Option Explicit
Public Property Get EscapeString() As String
EscapeString = this.EscapeString
End Property
Friend Property LetFunction EscapeStringCreate(valueescape As String)
this.EscapeString = value
End Property
Public Property Get, ReplacementString()replacement As String
ReplacementString = this.ReplacementString
End, Property
_
Friend Property Let ReplacementString(value As String)
this.ReplacementString = value
End Property
Public Property Get IsAsciiCharacter() As Boolean
IsAsciiCharacter = this.IsAsciiCharacter
End Property
Friend PropertyOptional LetByVal IsAsciiCharacter(valueisAsciiReplacement As Boolean)
this.IsAsciiCharacter = value
End Property
Public Property Get AsciiBase() As AsciiEscapeBase
AsciiBase = this.AsciiBase
EndFalse, Property
_
Friend Property Let AsciiBase(value As AsciiEscapeBase)
this.AsciiBase = value
End Property
Public Function Create(escape As String, replacement As String, Optional ByVal isAsciiReplacement As Boolean = False, Optional ByVal base As AsciiEscapeBase = Octal) As EscapeSequence
Dim result As New EscapeSequence
result.EscapeString = escape
result.ReplacementString = replacement
result.IsAsciiCharacter = isAsciiReplacement
result.AsciiBase = base
Set Create = result
End Function
Public Sub Execute(ByRef string_value As String)
If this.IsAsciiCharacter Then
ProcessAsciiEscape string_value, this.EscapeString
ElseIf StringContains(string_value, this.EscapeString) Then
string_value = Replace(string_value, this.EscapeString, this.ReplacementString)
End If
End Sub
Private Sub ProcessAsciiEscape(ByRef format_string As String, ByVal regexPattern As String)
Dim regex As RegExp, matches As MatchCollection, thisMatch As Match
Dim prefix As String, char As Long
If Not StringContains(format_string, "\") Then Exit Sub
Set regex = New RegExp
regex.pattern = regexPattern
regex.IgnoreCase = True
regex.Global = True
Set matches = regex.Execute(format_string)
If matches.Count = 0 Then GoTo normal_exit
Select Case this.AsciiBase
Case AsciiEscapeBase.Octal
prefix = "&O"
Case AsciiEscapeBase.Hexadecimal
prefix = "&H"
End Select
For Each thisMatch In matches
char = CLng(prefix & thisMatch.SubMatches(0))
format_string = Replace(format_string, thisMatch.value, Chr$(char))
Next
normal_exit:
Set regex = Nothing
Set matches = Nothing
End Sub
The cornerstone of this refactoring isAdded an Execute method here - all escape sequences boil down to the newsame thing: *replace the EscapeString with the ReplacementString, so we might as well encapsulate it here. ASCII escapes are a little bit more complex so I put them in their own method:
Public Sub Execute(ByRef string_value As String)
If this.IsAsciiCharacter Then
ProcessAsciiEscape string_value, this.EscapeString
ElseIf StringContains(string_value, this.EscapeString) Then
string_value = Replace(string_value, this.EscapeString, this.ReplacementString)
End If
End Sub
Private Sub ProcessAsciiEscape(ByRef format_string As String, _
ByVal regexPattern As String)
Dim regex As RegExp, matches As MatchCollection, thisMatch As Match
Dim prefix As String, char As Long
If Not StringContains(format_string, "\") Then Exit Sub
Set regex = New RegExp
regex.pattern = regexPattern
regex.IgnoreCase = True
regex.Global = True
Select Case this.AsciiBase
Case AsciiEscapeBase.Octal
prefix = "&O"
Case AsciiEscapeBase.Hexadecimal
prefix = "&H"
End Select
Set matches = regex.Execute(format_string)
For Each thisMatch In matches
char = CLng(prefix & thisMatch.SubMatches(0))
format_string = Replace(format_string, thisMatch.value, Chr$(char))
Next
Set regex = Nothing
Set matches = Nothing
End Sub
This puts escape sequences to bed, at least for now.
Format Specifiers
Each match in the main RegEx stands for a placeholder (something potentially looking like "{0,-10:C2}"); if we can call those "format specifiers", they can probably deserve their own StringFormatSpecifier class as well - the precision specifier is normally an Integer, but in the custom date format it's also taking a String so we'll make Precision a get-only property that's set when assigning CustomSpecifier:
Private Type tSpecifier
Index As Integer
identifier As String
AlignmentSpecifier As Integer
PrecisionSpecifier As Integer
CustomSpecifier As String
End Type
Private this As tSpecifier
Option Explicit
Public Property Get Index() As Integer
Index = this.Index
End Property
Public Property Let Index(value As Integer)
this.Index = value
End Property
Public Property Get identifier() As String
identifier = this.identifier
End Property
Public Property Let identifier(value As String)
this.identifier = value
End Property
Public Property Get Alignment() As Integer
Alignment = this.AlignmentSpecifier
End Property
Public Property Let Alignment(value As Integer)
this.AlignmentSpecifier = value
End Property
Public Property Get Precision() As Integer
Precision = this.PrecisionSpecifier
End Property
Public Property Get CustomSpecifier() As String
CustomSpecifier = this.CustomSpecifier
End Property
Public Property Let CustomSpecifier(value As String)
this.CustomSpecifier = value
If IsNumeric(value) And val(value) <> 0 Then this.PrecisionSpecifier = CInt(value)
End Property
Public Function ToString() As String
ToString = "{" & this.Index & IIf(this.AlignmentSpecifier <> 0, "," & this.AlignmentSpecifier, vbNullString) & _
IIf(this.identifier <> vbNullString, ":" & this.identifier, vbNullString) & _
IIf(this.CustomSpecifier <> vbNullString, this.CustomSpecifier, vbNullString) & "}"
End Function
Diving intoAll that's missing is a way to put all the pieces back together to perform the actual replacement - either we store the original string or we implement a StringHelperToString class, here's the actual refactored codefunction:
Private Const ERR_FORMAT_EXCEPTION As Long = vbObjectError Or 9001
Private Const ERR_SOURCE As String = "StringHelper"
Private Const ERR_MSG_INVALID_FORMAT_STRING As String = "Invalid format string."
Private Const ERR_MSG_FORMAT_EXCEPTION As String = "The number indicating an argument to format is less than zero, or greater than or equal to the length of the args array."
Private Type tString
Public Function PaddingCharacterToString() As String * 1
EscapeSequences As New Collection
NumericSpecifiers As New Collection
DateTimeSpecifiers As New Collection
End Type
Private Const PADDING_CHAR As String * 1ToString = " {"
Private this As tString
Option Base 0
Option Explicit
Private Sub Class_Initialize()
If this.PaddingCharacter = vbNullString Then& this.PaddingCharacter = PADDING_CHAR
InitEscapeSequences
InitNumericSpecifiers
InitDateTimeSpecifiers
End Sub
Private Sub InitEscapeSequences()
Index & _
Dim factory As New EscapeSequence
Set this.EscapeSequences = New Collection
this.EscapeSequences.Add factory.Create("\n", vbNewLine)
this.EscapeSequences.Add factory.Create("\q", Chr$IIf(34))
this.EscapeSequences.Add factory.Create("\t", vbTab)
AlignmentSpecifier this.EscapeSequences.Add<> factory.Create("\a"0, Chr$(7))_
this.EscapeSequences.Add factory.Create("\b", Chr$(8))
this.EscapeSequences.Add factory.Create("\v", Chr$(13))
this.EscapeSequences.Add factory.Create("\f", Chr$(14))
this.EscapeSequences.Add factory.Create("\r", Chr$(15))
this.EscapeSequences.Add factory.Create("\\x(\w{2})", 0, True, Hexadecimal)
this.EscapeSequences.Add factory.Create("\\(\d{3})", 0, True, Octal)
Set factory = Nothing
End Sub
Private Sub InitNumericSpecifiers()
Set this.NumericSpecifiers = New Collection
this.NumericSpecifiers.Add New CurrencyStringFormatIdentifier
this.NumericSpecifiers.Add New DecimalStringFormatIdentifier
this.NumericSpecifiers.Add New GeneralNumericStringFormatIdentifier
this.NumericSpecifiers.Add New PercentStringFormatIdentifier
this.NumericSpecifiers.Add New FixedPointStringFormatIdentifier
this.NumericSpecifiers.Add New ExponentialStringFormatIdentifier
this.NumericSpecifiers.Add New HexStringFormatIdentifier
this.NumericSpecifiers.Add New RoundTripStringFormatIdentifier
this.NumericSpecifiers.Add New NumericPaddingStringFormatIdentifier
End Sub
Private Sub InitDateTimeSpecifiers()
Set this.DateTimeSpecifiers = New Collection
this.DateTimeSpecifiers.Add New CustomDateFormatIdentifier
this.DateTimeSpecifiers.Add New FullDateLongStringFormatSpecifier
this.DateTimeSpecifiers.Add New FullDateShortStringFormatIdentifier
this.DateTimeSpecifiers.Add New GeneralLongDateTimeStringFormatIdentifier
this.DateTimeSpecifiers.Add New GeneralShortDateTimeStringFormatIdentifier
this.DateTimeSpecifiers.Add New LongDateFormatIdentifier
this.DateTimeSpecifiers.Add New LongTimeStringFormatIdentifier
this.DateTimeSpecifiers.Add New ShortDateFormatIdentifier
& this.DateTimeSpecifiers.Add New SortableDateTimeStringFormatIdentifier
End Sub
Public Function StringFormat(format_string As String, values() As Variant) As String
Dim result As String
result = format_string
Dim specifiers As Collection
Dim specifier As StringFormatSpecifier
Set specifiers = GetFormatSpecifiers(result, UBound(values) + 1)
Dim useLiteral As Boolean 'when format_string starts with "@", escapes are not replaced (string is treated as a literal string with placeholders)
useLiteral = StringStartsWith("@", result)
If useLiteral Then result = Right(result, Len(result) - 1) 'remove the "@" literal specifier from the result string
'replace escaped backslashes with 'ESC' character [Chr$(27)] to optimize escape sequences evaluation:
If Not useLiteral And StringContains(result, "\\") Then result = Replace(result, "\\"AlignmentSpecifier, Chr$(27))
Dim formattedValue As String
Dim alignmentPadding As Integer
Dim identifier As IStringFormatIdentifier
Dim identifierFound As Boolean
For Each specifier In specifiers
formattedValue = values(specifier.Index)
identifierFound = (specifier.identifier = vbNullString)
If IsNumeric(values(specifier.Index)) Then
For Each identifier In this.NumericSpecifiers
If identifier.IsIdentifierMatch(specifier) Then
identifierFound = True
formattedValue = identifier.GetFormattedValue(values(specifier.Index), specifier)
End If
& Next_
ElseIf TypeName(valuesIIf(specifier.Index)) = "Date" Then
For Each identifier In this.DateTimeSpecifiers
If identifier.IsIdentifierMatch(specifier) Then
identifierFound = True
formattedValue = identifier.GetFormattedValue(values(specifier.Index), specifier)
End If
Next
End If
If Not identifierFound Then Err.Raise ERR_FORMAT_EXCEPTION,<> ERR_SOURCEvbNullString, ERR_MSG_INVALID_FORMAT_STRING
alignmentPadding = Abs(specifier.Alignment)
If specifier.Alignment < 0 Then
'negative: left-justified alignment
If alignmentPadding - Len(formattedValue) > 0 Then _
formattedValue = formattedValue & String$(alignmentPadding - Len(formattedValue), this.PaddingCharacter)
ElseIf specifier.Alignment > 0 Then
'positive": right-justified alignment
If alignmentPadding - Len(formattedValue) > 0 Then _
formattedValue = String$(alignmentPadding - Len(formattedValue), this.PaddingCharacter)" & formattedValue
End If
'replace all occurrences of placeholder {i} with their formatted values:
result = Replace(result, specifier.ToString, formattedValue)
Next
Dim escape As EscapeSequence
If Not useLiteral And StringContains(result, "\") Then
For Each escape In this.EscapeSequences
escape.Execute result
Next
End If
If Not useLiteral And StringContains(result, Chr$(27)) Then result = Replace(result, Chr$(27), "\")
StringFormat = result
End Function
Private Function GetFormatSpecifiers(ByVal format_string As String, valuesCount As Integer) As Collection
'executes a regular expression against format_string to extract all placeholders into a MatchCollection
Dim regex As New RegExp
Dim matches As MatchCollection
Dim thisMatch As Match
Dim result As New Collection
Dim specifier As StringFormatSpecifier
Dim csvIndices As String
Dim uniqueCount As Integer
Dim largestIndex As Integer
regex.pattern = "\{(\w+)(\,\-?\d+)?(\:[^}]+)?\}"
' literal {
' [1] numbered captured group, any number of repetitions (Index)
' alphanumeric, one or more repetitions
' [2] numbered captured group, zero or one repetitions (AlignmentSpecifier)
' literal ,
' literal -, zero or one repetitions
' any digit, one or more repetitions
' [3] numbered captured group, zero or one repetitions (FormatSpecifier)
' literal :
' any character except '}', one or more repetitions
' literal }
regex.IgnoreCase = True
regex.Global = True
Set matches = regex.Execute(format_string)
For Each thisMatch In matches
Set specifier = New StringFormatSpecifier
specifier.Index = CInt(thisMatch.SubMatches(0))
If Not StringContains(csvIndicesidentifier, specifier.Index & ","vbNullString) Then
uniqueCount = uniqueCount + 1
csvIndices = csvIndices & specifier.Index & ","
End If_
If specifier.Index > largestIndex Then largestIndex = specifier.Index
If Not thisMatch.SubMatchesIIf(1) = vbEmpty Then specifierthis.Alignment =CustomSpecifier CInt(Replace(CStr(thisMatch.SubMatches(1)),<> ","vbNullString, vbNullString))_
If Not thisMatch.SubMatches(2) = vbEmpty Then
specifier.identifier = Left(Replace(CStr(thisMatchthis.SubMatches(2)), ":"CustomSpecifier, vbNullString), 1)
specifier.CustomSpecifier = Replace(CStr(thisMatch.SubMatches(2)),& ":}" & specifier.identifier, vbNullString)
End If
result.Add specifier
Next
If matches.Count > 0 And (uniqueCount <> valuesCount) Or (largestIndex >= uniqueCount) Or valuesCount = 0) Then Err.Raise ERR_FORMAT_EXCEPTION, ERR_SOURCE, ERR_MSG_FORMAT_EXCEPTION
Set GetFormatSpecifiers = result
Set regex = Nothing
Set matches = Nothing
End Function
What did the trick for getting ridThis puts another important piece to bed.
VB6 Interface?
If we encapsulated how each format specifier works into its own class, odds are we'd get over a dozen of Select...Casevery similar classes. If only we were in .net, was defining awe could create an interface for this, right? Very few people know that VB6 also supports interfaces. In fact, any class can be implemented by any other.
So the IStringFormatIdentifier classinterface/interface - not many people know it's possible to define and implement interfaces in VB6. This shows how it could be doneclass looks like this:
Option Explicit
'returns a format string suitable for use with VB6's native Format() function.
Public Function GetFormatString(specifier As StringFormatSpecifier) As String
End Function
'returns the formatted value.
Public Function GetFormattedValue(value As Variant, _
specifier As StringFormatSpecifier) As String
End Function
'compares specified format identifier with implementation-defined one, returns
'returns true if format is applicable.
Public Function IsIdentifierMatch(specifier As StringFormatSpecifier) As Boolean
End Function
...and This interface needs an implementation of it for each and every single Case block of the original code - not going to list them all here, but this is GeneralNumericStringFormatIdentifier (the most complicated one); notice that doing this has also eliminated the recursive function calls:
Implements IStringFormatIdentifier
Option Explicit
Private Function IStringFormatIdentifier_GetFormatString(specifier As StringFormatSpecifier) As String
IStringFormatIdentifier_GetFormatString = vbNullString
End Function
Private Function IStringFormatIdentifier_GetFormattedValue(value As Variant, specifier As StringFormatSpecifier) As String
Dim result As String
Dim exponentialNotation As String
Dim power As Integer
Dim exponentialFormat As New ExponentialStringFormatIdentifier
Dim fixedPointFormat As New FixedPointStringFormatIdentifier
Dim decimalFormat As New DecimalStringFormatIdentifier
Dim formatSpecifier As New StringFormatSpecifier
formatSpecifier.Alignment = specifier.Alignment
formatSpecifier.CustomSpecifier = specifier.CustomSpecifier
If StringMatchesAny(TypeName(value), "Integer", "Long") Then
formatSpecifier.identifier = IIf(specifier.identifier = "G", "D", "d")
result = decimalFormat.GetFormattedValue(value, formatSpecifier)
ElseIf TypeName(value) = "Double" Then
formatSpecifier.identifier = IIf(specifier.identifier = "G", "E", "e")
exponentialNotation = exponentialFormat.GetFormattedValue(value, formatSpecifier)
power = exponentialFormat.GetPower(exponentialNotation)
If power > -5 And Abs(power) < specifier.Precision Then
formatSpecifier.identifier = IIf(specifier.identifier = "G", "F", "f")
result = fixedPointFormat.GetFormattedValue(value, formatSpecifier)
Else
result = exponentialNotation
End If
End If
IStringFormatIdentifier_GetFormattedValue = result
Set exponentialFormat = Nothing
Set fixedPointFormat = Nothing
Set decimalFormat = Nothing
Set formatSpecifier = Nothing
End Function
Public Function GetFormattedValue(value As Variant, specifier As StringFormatSpecifier) As String
GetFormattedValue = IStringFormatIdentifier_GetFormattedValue(value, specifier)
End Function
Private Function IStringFormatIdentifier_IsIdentifierMatch(specifier As StringFormatSpecifier) As Boolean
IStringFormatIdentifier_IsIdentifierMatch = UCase$(specifier.identifier) = "G"
End Function
Once every format identifier ("C", "D", "N", etc.) has its implementation of the IStringFormatIdentifier interface, we're ready to initialize everything we need, once.
The StringHelper class
Diving into the StringHelper class, the "declarations" section contains the error-handling constants, the default padding character and a private type that defines the encapsulated properties (I just do that in every class I write):
Private Const ERR_FORMAT_EXCEPTION As Long = vbObjectError Or 9001
Private Const ERR_SOURCE As String = "StringHelper"
Private Const ERR_MSG_INVALID_FORMAT_STRING As String = "Invalid format string."
Private Const ERR_MSG_FORMAT_EXCEPTION As String = "The number indicating an argument to format is less than zero, or greater than or equal to the length of the args array."
Private Type tString
PaddingCharacter As String * 1
EscapeSequences As New Collection
NumericSpecifiers As New Collection
DateTimeSpecifiers As New Collection
End Type
Private Const PADDING_CHAR As String * 1 = " "
Private this As tString
Option Base 0
Option Explicit
Method Class_Initialize is where all the one-time stuff happens - this is where escape sequences, numeric and datetime specifiers are initialized:
Private Sub Class_Initialize()
If this.PaddingCharacter = vbNullString Then this.PaddingCharacter = PADDING_CHAR
InitEscapeSequences
InitNumericSpecifiers
InitDateTimeSpecifiers
End Sub
Private Sub InitEscapeSequences()
Dim factory As New EscapeSequence
Set this.EscapeSequences = New Collection
this.EscapeSequences.Add factory.Create("\n", vbNewLine)
this.EscapeSequences.Add factory.Create("\q", Chr$(34))
this.EscapeSequences.Add factory.Create("\t", vbTab)
this.EscapeSequences.Add factory.Create("\a", Chr$(7))
this.EscapeSequences.Add factory.Create("\b", Chr$(8))
this.EscapeSequences.Add factory.Create("\v", Chr$(13))
this.EscapeSequences.Add factory.Create("\f", Chr$(14))
this.EscapeSequences.Add factory.Create("\r", Chr$(15))
this.EscapeSequences.Add factory.Create("\\x(\w{2})", 0, True, Hexadecimal)
this.EscapeSequences.Add factory.Create("\\(\d{3})", 0, True, Octal)
Set factory = Nothing
End Sub
Private Sub InitNumericSpecifiers()
Set this.NumericSpecifiers = New Collection
this.NumericSpecifiers.Add New CurrencyStringFormatIdentifier
this.NumericSpecifiers.Add New DecimalStringFormatIdentifier
this.NumericSpecifiers.Add New GeneralNumericStringFormatIdentifier
this.NumericSpecifiers.Add New PercentStringFormatIdentifier
this.NumericSpecifiers.Add New FixedPointStringFormatIdentifier
this.NumericSpecifiers.Add New ExponentialStringFormatIdentifier
this.NumericSpecifiers.Add New HexStringFormatIdentifier
this.NumericSpecifiers.Add New RoundTripStringFormatIdentifier
this.NumericSpecifiers.Add New NumericPaddingStringFormatIdentifier
End Sub
Private Sub InitDateTimeSpecifiers()
Set this.DateTimeSpecifiers = New Collection
this.DateTimeSpecifiers.Add New CustomDateFormatIdentifier
this.DateTimeSpecifiers.Add New FullDateLongStringFormatSpecifier
this.DateTimeSpecifiers.Add New FullDateShortStringFormatIdentifier
this.DateTimeSpecifiers.Add New GeneralLongDateTimeStringFormatIdentifier
this.DateTimeSpecifiers.Add New GeneralShortDateTimeStringFormatIdentifier
this.DateTimeSpecifiers.Add New LongDateFormatIdentifier
this.DateTimeSpecifiers.Add New LongTimeStringFormatIdentifier
this.DateTimeSpecifiers.Add New ShortDateFormatIdentifier
this.DateTimeSpecifiers.Add New SortableDateTimeStringFormatIdentifier
End Sub
To make the PaddingCharacter configurable, it only needs to be exposed as a property.
So let's recap here, we have:
- A collection of escape sequences that know how to to process themselves
- A collection of numeric specifiers that know how to process themselves
- A collection of date/time specifiers that know how to process themselves
All we're missing is a function that will take a format_string, validate it and return a collection of StringFormatSpecifier. The regular expression we're using to do this can also be simplified a bit - unfortunately this doesn't make it run any faster (performance-wise, this function is really where the bottleneck is):
Private Function GetFormatSpecifiers(ByVal format_string As String, valuesCount As Integer) As Collection
'executes a regular expression against format_string to extract all placeholders into a MatchCollection
Dim regex As New RegExp
Dim matches As MatchCollection
Dim thisMatch As Match
Dim result As New Collection
Dim specifier As StringFormatSpecifier
Dim csvIndices As String
Dim uniqueCount As Integer
Dim largestIndex As Integer
regex.pattern = "\{(\w+)(\,\-?\d+)?(\:[^}]+)?\}"
' literal {
' [1] numbered captured group, any number of repetitions (Index)
' alphanumeric, one or more repetitions
' [2] numbered captured group, zero or one repetitions (AlignmentSpecifier)
' literal ,
' literal -, zero or one repetitions
' any digit, one or more repetitions
' [3] numbered captured group, zero or one repetitions (FormatSpecifier)
' literal :
' any character except '}', one or more repetitions
' literal }
regex.IgnoreCase = True
regex.Global = True
Set matches = regex.Execute(format_string)
For Each thisMatch In matches
Set specifier = New StringFormatSpecifier
specifier.Index = CInt(thisMatch.SubMatches(0))
If Not StringContains(csvIndices, specifier.Index & ",") Then
uniqueCount = uniqueCount + 1
csvIndices = csvIndices & specifier.Index & ","
End If
If specifier.Index > largestIndex Then largestIndex = specifier.Index
If Not thisMatch.SubMatches(1) = vbEmpty Then specifier.Alignment = CInt(Replace(CStr(thisMatch.SubMatches(1)), ",", vbNullString))
If Not thisMatch.SubMatches(2) = vbEmpty Then
specifier.identifier = Left(Replace(CStr(thisMatch.SubMatches(2)), ":", vbNullString), 1)
specifier.CustomSpecifier = Replace(CStr(thisMatch.SubMatches(2)), ":" & specifier.identifier, vbNullString)
End If
result.Add specifier
Next
If matches.Count > 0 And (uniqueCount <> valuesCount) Or (largestIndex >= uniqueCount) Or valuesCount = 0) Then Err.Raise ERR_FORMAT_EXCEPTION, ERR_SOURCE, ERR_MSG_FORMAT_EXCEPTION
Set GetFormatSpecifiers = result
Set regex = Nothing
Set matches = Nothing
End Function
The actual StringFormat function takes an array of Variant sent from the module function's ParamArray values() parameter; taking a ParamArray here as well would make things more complicated than they already are.
So all the function really needs to do, is loop through all specifiers in format_string, and apply the appropriate format specifier's formatting. Then apply the alignment specifier and execute escape sequences (unless format_string starts with a "@") - with everything properly encapsulated in specialized objects, this should leave a pretty readable implementation:
Public Function StringFormat(format_string As String, values() As Variant) As String
Dim result As String
result = format_string
Dim specifiers As Collection
Dim specifier As StringFormatSpecifier
Set specifiers = GetFormatSpecifiers(result, UBound(values) + 1)
Dim useLiteral As Boolean
'when format_string starts with "@", escapes are not replaced
'(string is treated as a literal string with placeholders)
useLiteral = StringStartsWith("@", result)
'remove the "@" literal specifier from the result string
If useLiteral Then result = Right(result, Len(result) - 1)
'replace escaped backslashes with 'ESC' character [Chr$(27)]
'to optimize escape sequences evaluation:
If Not useLiteral And StringContains(result, "\\") Then _
result = Replace(result, "\\", Chr$(27))
Dim formattedValue As String
Dim alignmentPadding As Integer
Dim identifier As IStringFormatIdentifier
Dim identifierFound As Boolean
For Each specifier In specifiers
formattedValue = values(specifier.Index)
identifierFound = (specifier.identifier = vbNullString)
If IsNumeric(values(specifier.Index)) Then
For Each identifier In this.NumericSpecifiers
If identifier.IsIdentifierMatch(specifier) Then
identifierFound = True
formattedValue = identifier.GetFormattedValue(values(specifier.Index), specifier)
End If
Next
ElseIf TypeName(values(specifier.Index)) = "Date" Then
For Each identifier In this.DateTimeSpecifiers
If identifier.IsIdentifierMatch(specifier) Then
identifierFound = True
formattedValue = identifier.GetFormattedValue(values(specifier.Index), specifier)
End If
Next
End If
If Not identifierFound Then Err.Raise ERR_FORMAT_EXCEPTION, ERR_SOURCE, ERR_MSG_INVALID_FORMAT_STRING
alignmentPadding = Abs(specifier.Alignment)
If specifier.Alignment < 0 Then
'negative: left-justified alignment
If alignmentPadding - Len(formattedValue) > 0 Then _
formattedValue = formattedValue & String$(alignmentPadding - Len(formattedValue), this.PaddingCharacter)
ElseIf specifier.Alignment > 0 Then
'positive: right-justified alignment
If alignmentPadding - Len(formattedValue) > 0 Then _
formattedValue = String$(alignmentPadding - Len(formattedValue), this.PaddingCharacter) & formattedValue
End If
'replace all occurrences of placeholder {i} with their formatted values:
result = Replace(result, specifier.ToString, formattedValue)
Next
Dim escape As EscapeSequence
If Not useLiteral And StringContains(result, "\") Then
For Each escape In this.EscapeSequences
escape.Execute result
Next
End If
If Not useLiteral And StringContains(result, Chr$(27)) Then result = Replace(result, Chr$(27), "\")
StringFormat = result
End Function