I have a bit of a dilema. I am receiving an array of arrays that contains a string in the first element of an array that denotes a hash {HASH}. I dont know the structure of the array of arrays it can be different based upon the result of different calls. An example of the data is as follows:
[ [ "{HASH}", 1000, ["{HASH}", "A", 100], ["{HASH}", "B", 150], ["{HASH}", "C", 200] ],
[ "{HASH}", 1001, ["{HASH}", "D", 101], ["{HASH}", "E", 151], ["{HASH}", "F", 201] ]
]
The hash should then be as follows:
{1000}{A}=100
{1000}{B}=150
{1000}{c}=200
{1001}{D}=101
{1001}{E}=151
{1001}{F}=201
I have written the following function to be called recurrsively to output the entries in the arrays this is fine, but I need to put this into a Hash as defined and this is where it is failing, because as it is called recursively the hashes are reset etc:
Public Function ProcessObjOrArray(Obj As Variant, key As String, ByRef hashIn, HashCreated As Boolean) As Variant
Dim sKey As String
Dim i As Integer
Dim objRes As Variant
If HashCreated = False Then
Dim hash
HashCreated = True
Set hash = CreateObject("Scripting.Dictionary")
End If
If IsArray(Obj) Then
For i = 0 To UBound(Obj, 1)
objRes = ProcessObjOrArray(Obj(i), sKey, hash, HashCreated)
If (objRes = "{HASH}") Then
i = i + 1
sKey = Obj(i)
End If
Next i
If key <> "" Then
Debug.Print "Adding {" + key + "}=AllTheStuff"
Set hash.Item(key) = hashIn
Dim a
a = hash.Item(key)("Enabled")
Exit Function
End If
Else
If key <> "" Then
Debug.Print "Adding {" + key + "}=" + CStr(Obj)
hash.Item(key) = Obj
Else
ProcessObjOrArray = Obj
End If
End If
End Function
The Object passed in is obviously the array I defined above. If someone has a smart way of doing this it would be much appreciated.
I solved the issue, by using a hash passed in and at the end point, creating a new hash which is a copy of the hash passed in, and then finally reset the hash passed in and set is key and value = to the hash I copied. This successfully creates the Hash of hashes
Related
I was wondering if there was any way to change the number of dimensions of an array:
In VBA,
Depending on an integer max_dim_bound which indicates the the
desired nr. of dimensions.
Allowing for a starting index of the dimension: E.G. `array(4 to 5, 3 to 6) where the number of 3 to 6 are variable integers.
*In the code itself without extra tools
*Without exporting the code.
To be clear, the following change does not change the nr of dimensions of an array, (merely the starting end ending indices of the elements in each respective dimension):
my_arr(3 to 5, 6 to 10)
'changed to:
my_arr(4 to 8, 2 to 7)
The following example would be a successfull change of the nr. of dimensions in an array:
my_arr(3 to 5, 6 to 10)
'changed to:
my_arr(4 to 8, 2 to 7,42 to 29)
This would also be a change in the nr. of dimensions in an array:
my_arr(4 to 8, 2 to 7,42 to 29)
'changed to:
my_arr(3 to 5, 6 to 10)
So far my attempts have consisted of:
Sub test_if_dynamically_can_set_dimensions()
Dim changing_dimension() As Double
Dim dimension_string_attempt_0 As String
Dim dimension_string_attempt_1 As String
Dim max_dim_bound As String
Dim lower_element_boundary As Integer
Dim upper_element_boundary As Integer
upper_element_boundary = 2
max_dim_bound = 4
For dimen = 1 To max_dim_bound
If dimen < max_dim_bound Then
dimension_string_attempt_0 = dimension_string_attempt_0 & "1 To " & upper_element_boundary & ","
MsgBox (dimension_string_attempt_0)
Else
dimension_string_attempt_0 = dimension_string_attempt_0 & "1 To " & upper_element_boundary
End If
Next dimen
MsgBox (dimension_string_attempt_0)
'ReDim changing_dimension(dimension_string_attempt_0) 'does not work because the "To" as expected in the array dimension is not a string but reserved word that assists in the operation of setting an array's dimension(s)
'ReDim changing_dimension(1 & "To" & 3, 1 To 3, 1 To 3) 'does not work because the word "To" that is expected here in the array dimension is not a string but a reserved word that assists the operation of setting an array's dimension(s).
'ReDim changing_dimension(1 To 3, 1 To 3, 1 To 3, 1 To 3)
'attempt 1:
For dimen = 1 To max_dim_bound
If dimen < max_dim_bound Then
dimension_string_attempt_1 = dimension_string_attempt_1 & upper_element_boundary & ","
MsgBox (dimension_string_attempt_1)
Else
dimension_string_attempt_1 = dimension_string_attempt_1 & upper_element_boundary
End If
Next dimen
MsgBox (dimension_string_attempt_1)
ReDim changing_dimension(dimension_string_attempt_1) 'this does not change the nr of dimensions to 2, but just one dimension of "3" and "3" = "33" = 33 elements + the 0th element
'changing_dimension(2, 1, 2, 1) = 4.5
'MsgBox (changing_dimension(2, 1, 2, 1))
End Sub
*Otherwise a solution is to:
Export the whole code of a module, and at the line of the dimension substitute the static redimension of the array, with the quasi-dynamic string dimension_string.
Delete the current module
Import the new module with the quasi-dynamic string dimension_string as a refreshed static redimension in the code.
However, it seems convoluted and I am curious if someone knows a simpler solution.
Note that this is not a duplicate of: Dynamically Dimensioning A VBA Array? Even though the question seems to mean what I am asking here, the intention of the question seems to be to change the nr. of elements in a dimension, not the nr. of dimensions. (The difference is discussed in this article by Microsoft.)
In an attempt to apply the answer of Uri Goren, I analyzed every line and looked up what they did, and commented my understanding behind it, so that my understanding can be improved or corrected. Because I had difficulty not only running the code, but also understanding how this answers the question. This attempt consisted of the following steps:
Right click the code folder ->Insert ->Class Module Then clicked:
Tools>Options> "marked:Require variable declaration" as shown
here at 00:59.
Next I renamed the class module to
Next I wrote the following code in class module FlexibleArray:
Option Explicit
Dim A As New FlexibleArray
Private keys() As Integer
Private vals() As String
Private i As Integer
Public Sub Init(ByVal n As Integer)
ReDim keys(n) 'changes the starting element index of array keys to 0 and index of last element to n
ReDim vals(n) 'changes the starting element index of array keys to 0 and index of last element to n
For i = 1 To n
keys(i) = i 'fills the array keys as with integers from 1 to n
Next i
End Sub
Public Function GetByKey(ByVal key As Integer) As String
GetByKey = vals(Application.Match(key, keys, False))
' Application.Match("what you want to find as variant", "where you can find it as variant", defines the combination of match type required and accompanying output)
'Source: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/worksheetfunction-match-method-excel
' If match_type is 1, MATCH finds the largest value that is less than or equal to lookup_value. Lookup_array must be placed in ascending order: ...-2, -1, 0, 1, 2, ..., A-Z, FALSE, TRUE.
' If match_type is 0, MATCH finds the first value that is exactly equal to lookup_value. Lookup_array can be in any order.
' If match_type is -1, MATCH finds the smallest value that is greater than or equal to lookup_value. Lookup_array must be placed in descending order: TRUE, FALSE, Z-A, ...2, 1, 0, -1, -2, ..., and so on.
'so with False as 3rd optional argument "-1" it finds the smallest value greater than or equal to the lookup variant, meaning:
'the lowest value of keys that equals or is greater than key is entered into vals,
'with keys as an array of 1 to n, it will return key, if n >= key. (if keys is initialized right before getbykey is called and is not changed inbetween.
'vals becomes the number inside a string. So vals becomes the number key if key >= n.
End Function
Public Sub SetByKey(ByVal key As Integer, ByVal val As String)
vals(Application.Match(key, keys, False)) = val
'here string array vals(element index: key) becomes string val if key >=n (meaning if the element exists)
End Sub
Public Sub RenameKey(ByVal oldName As Integer, ByVal newName As Integer)
keys(Application.Match(oldName, keys, False)) = newName
'here keys element oldname becomes new name if it exists in keys.
End Sub
And then I created a new module11 and copied the code below in it, including modifications to try and get the code working.
Option Explicit
Sub use_class_module()
Dim A As New FlexibleArray 'this dimensions object A but it is not set yet
A.Init (3) 'calls the public sub "Init" in class module FlexibleArray, and passes integer n = 3.
'A.SetByKey(1, "a") 'this means that Objecgt A. in class FlexibleArray function SetByKey sets the private string array vals(1) in class Flexible Array becomes "a"
'A.SetByKey(2, "b") 'this means that Objecgt A. in class FlexibleArray function SetByKey sets the private string array vals(2) in class Flexible Array becomes "b"
'A.SetByKey(3, "c") 'this means that Object A. in class FlexibleArray function SetByKey sets the private string array vals(3) in class Flexible Array becomes "c"
'A.RenameKey(3,5) 'This means that object A in class FlexibleArray keys element 3 becomes 5 so keys(3) = 5
' Would print the char "c"
'to try to use the functions:
'A.SetByKey(1, "a") = 4
'MsgBox (keys("a"))
'test = A.SetByKey(1, "a") 'this means that Objecgt A. in class FlexibleArray function SetByKey sets the private string array vals(1) in class Flexible Array becomes "a"
'MsgBox (test)
'test_rename = A.RenameKey(3, 5) 'This means that object A in class FlexibleArray keys element 3 becomes 5 so keys(3) = 5
'MsgBox (test_rename)
'Print A.GetByKey(5) 'Method not valid without suitable object
'current problem:
'the A.SetByKey expects a function or variable, even though it appears to be a function itself.
End Sub
What I currently expect that this code replaces the my_array(3 to 4,5 to 9..) to an array that exists in/as the class module FlexibleArray, that is called when it needs to be used in the module. But Any clearifications would be greatly appreciated! :)
If the goal of redimensioning arrays is limited to a non-absurd number of levels, a simple function might work for you, say for 1 to 4 dimensions?
You could pass the a string representing the lower and upper bounds of each dimension and that pass back the redimensioned array
Public Function FlexibleArray(strDimensions As String) As Variant
' strDimensions = numeric dimensions of new array
' eg. "1,5,3,6,2,10" creates ARRAY(1 To 5, 3 To 6, 2 To 10)
Dim arr() As Variant
Dim varDim As Variant
Dim intDim As Integer
varDim = Split(strDimensions, ",")
intDim = (UBound(varDim) + 1) / 2
Select Case intDim
Case 1
ReDim arr(varDim(0) To varDim(1))
Case 2
ReDim arr(varDim(0) To varDim(1), varDim(2) To varDim(3))
Case 3
ReDim arr(varDim(0) To varDim(1), varDim(2) To varDim(3), varDim(4) To varDim(5))
Case 4
ReDim arr(varDim(0) To varDim(1), varDim(2) To varDim(3), varDim(4) To varDim(5), varDim(6) To varDim(7))
End Select
' Return re-dimensioned array
FlexibleArray = arr
End Function
Test it by calling it with your array bounds
Public Sub redimarray()
Dim NewArray() As Variant
NewArray = FlexibleArray("1,2,3,8,2,9")
End Sub
Should come back with an array looking like this in Debug mode
EDIT - Added Example of truly dynamic array of variant arrays
Here's an example of a way to get a truly flexible redimensioned array, but I'm not sure it's what you're looking for as the firt index is used to access the other array elements.
Public Function FlexArray(strDimensions As String) As Variant
Dim arrTemp As Variant
Dim varTemp As Variant
Dim varDim As Variant
Dim intNumDim As Integer
Dim iDim As Integer
Dim iArr As Integer
varDim = Split(strDimensions, ",")
intNumDim = (UBound(varDim) + 1) / 2
' Setup redimensioned source array
ReDim arrTemp(intNumDim)
iArr = 0
For iDim = LBound(varDim) To UBound(varDim) Step 2
ReDim varTemp(varDim(iDim) To varDim(iDim + 1))
arrTemp(iArr) = varTemp
iArr = iArr + 1
Next iDim
FlexArray = arrTemp
End Function
And if you look at it in Debug, you'll note the redimensioned sub arrays that are now accessible from the first index of the returned array
Sounds like you are abusing arrays for something they weren't meant to do with a ton of memory copying.
What you want is to write your own Class (Right click the code folder ->Insert ->Class Module), let's call it FlexibleArray.
Your class code would be something like this:
Private keys() as Integer
Private vals() as String
Private i as Integer
Public Sub Init(ByVal n as Integer)
Redim keys(n)
Redim vals(n)
For i = 1 to n
keys(i) = i
Next i
End Sub
Public Function GetByKey(ByVal key As Integer) As String
GetByKey = vals(Application.Match(key, keys, False))
End Function
Public Sub SetByKey(ByVal key As Integer, ByVal val As String)
vals(Application.Match(key, keys, False)) = val
End Sub
Public Sub RenameKey(ByVal oldName As Integer, ByVal newName As Integer)
keys(Application.Match(oldName, keys, False))=newName
End Sub
Now you can rename whatever key you want:
Dim A as New FlexibleArray
A.Init(3)
A.SetByKey(1, "a")
A.SetByKey(2, "b")
A.SetByKey(3, "c")
A.RenameKey(3,5)
Print A.GetByKey(5)
' Would print the char "c"
Extending it to integer ranges (like your example) is pretty straight forward
How do I irate through a list/array in vb.net and also keep the count of the current item I'm on without having to declare an explicit counter variable?
The result that I am trying to achieve is as follows.
dim i as integer = 0 'evil counter variable
dim arr() as string = {"a","b","c","d","e"}
for each item in arr
console.writeline("Item """ & item & """ is index " & i)
i+=1
next
Without having to declare "i" on its own line
Python has a shorthand way of doing this as follows.
arr=["a","b","c","d","e"]
for i, item in enumerate(arr):
print("Item """ + item + """ is index " + str(i))
A similar implementation in vb.net would be ideal.
edit
The significant part of the code is the enumeration. Not the printing of the values.
Dim arr() As String = {"a", "b", "c", "d", "e"}
For i = 0 To arr.GetUpperBound(0)
Debug.Print($"Item {arr(i)} is index {i}")
Next
The list of possible solutions would not be complete without a Reflection hack, so let's go old school and use an enumerator
Dim arr() As String = {"a", "b", "c", "d", "e"}
Dim enumer As IEnumerator = arr.GetEnumerator
Dim fi As Reflection.FieldInfo = enumer.GetType.GetField("_index", Reflection.BindingFlags.Instance Or Reflection.BindingFlags.NonPublic)
While enumer.MoveNext
Dim item As String = DirectCast(enumer.Current, String)
Console.WriteLine($"item: {item} is at index: {fi.GetValue(enumer)}")
End While
A little explanation is needed. arr.GetEnumerator returns a SZArrayEnumerator. This enumerator uses the private field _index to keep track of the array index of the item returned by the Enumerator. The code uses reflection to access the value of _index.
Since this is not a generic Enumerator, the type returned by the Current property is System.Object and needs to be cast back to a String.
As an alternative, you could use string.Join() on a Linq Select():
Console.Write(String.Join(vbCrLf, arr.Select(Function(s, i) "Item " & s & " is Index " & i)))
It's not as good as the Python way, but this will do as you require:
dim arr() as string = {"a","b","c","d","e"}
for i as integer = 0 to arr.length - 1
console.writeline("Item """ & arr(i) & """ is index " & i)
next
Again, not as clean but it does as you need :)
so I am making a decryption software that allows the user to input some text and then they can swap out letters in the program. For example, there is a drop down box that allows you to swap all the "O"'s in a user input to "W". So in the input "Stack overflow" the output would be "Stack wverflww".
However, my problem is is that when the user chooses a second letter to change, that has already been swapped, it causes a problem. For example, after the first above example has occurred, if the user then wanted to then change all the "W"'s in their input to "A"'s the output would be "stack averflaa". However, what I'm looking for the code to do is give an output of "Stack wverflwa". So only the original "W"'s of the user input are changed to the letter "A".
I hope the above makes sense.
Someone suggested using a two dimensional array to reassign the letters new letters and I am able to do this, but I have no idea how to then put this into my code and get it working. Below is my code and thank you to anyone who can help me.
Dim chooseLetter, replaceLetter, words2
chooseLetter = selectLetterCombo.Text
replaceLetter = replaceLetterCombo.Text
words2 = UCase(textInputBox.Text)
Dim replaceList As New List(Of String)
For Each z In words2
If z = chooseLetter Then
replaceList.Add(replaceLetter)
Else
replaceList.Add(z)
End If
Next
letterReplaceBox.Text = ""
For Each f In replaceList
letterReplaceBox.Text = letterReplaceBox.Text & f
Next
note: selectLetterCombo.Text is the letter chosen by the user that they want to replace and replaceLetterCombo.Text is the letter chosen by the user that they want to swap the first chosen letter with. Also, textInputBox.text is the text the user has inputted.
Thank you!
You should be able to keep a list of the index of the character that changed and check that before making another change.
'List to keep track of changed character index
Dim replacedCharsList As New List(Of Integer)'member variable
Dim chooseLetter, replaceLetter, words2
chooseLetter = selectLetterCombo.Text
replaceLetter = replaceLetterCombo.Text
words2 = UCase(textInputBox.Text)
Dim replaceList As New List(Of String)
Dim i As Integer
For i = 1 To Len(words2)
'remove the for each and go with a straight for loop to keep track if the index
If Mid(words2, i, 1) = chooseLetter Then
'check to see if we have already replaced this character via the index position
If replacedCharsList.Contains(i) = False Then
'we have not changed this so add the replacement letter and update our index list
replaceList.Add(replaceLetter)
replacedCharsList.Add(i)
Else
'we have already changed this character so just add it as is
replaceList.Add(Mid(words2, i, 1))
End If
Else
replaceList.Add(Mid(words2, i, 1))
End If
Next
letterReplaceBox.Text = ""
For Each f In replaceList
letterReplaceBox.Text = letterReplaceBox.Text & f
Next
I have an answer, but you're really not going to like it:
Option Infer On
Option Strict On
Imports System.Text.RegularExpressions
Module Module1
Dim swaps As New Dictionary(Of Char, Char)
Function DoSwaps(originalText As String, swapLetters As Dictionary(Of Char, Char)) As String
Dim newText As String = ""
For Each c In originalText
If swapLetters.ContainsKey(c) Then
newText &= swapLetters(c)
Else
newText &= c
End If
Next
Return newText
End Function
Sub Main()
Console.Write("Enter the text to be altered: ")
Dim t = Console.ReadLine()
Dim exitNow = False
Do
Console.Write("Enter the letter to swap from and the letter to swap to, or a blank line to quit: ")
Dim s = Console.ReadLine()
If s.Trim().Length = 0 Then
exitNow = True
Else
Dim parts = Regex.Matches(s, "([A-Za-z])")
If parts.Count >= 2 Then
Dim letter1 = CChar(parts.Item(0).Value)
Dim letter2 = CChar(parts.Item(1).Value)
If swaps.ContainsKey(letter1) Then
swaps.Item(letter1) = letter2
Else
swaps.Add(letter1, letter2)
End If
Console.WriteLine(DoSwaps(t, swaps))
End If
End If
Loop Until exitNow
End Sub
End Module
... unless you'd like to learn about the Dictionary class to understand how it works. I used a simple regular expression to parse the user input, but if you're using dropdowns to select the letters then that would just be bonus learning if you explore it.
The essential feature is that you keep the original string (t in the above code) and apply the transformation (I named it DoSwaps) to that each time, not to the previously transformed string.
These two functions will do the job, although there is no allowance for punctuation, just spaces.
Private Function EncryptText(str As String) As String
Dim swapletters() As String = {"l", "s", "d", "f", "g", "h", "j", "k", "a", "q", "w", "e", "r", "t", "y", "u", "i", "o", "p", "z", "x", "c", "v", "b", "n", "m"}
Dim encryptedText As String = ""
For Each letter As Char In str
If letter = " "c Then
encryptedText = encryptedText & " "
Else
Dim charactercode As Integer = Asc(letter) - 97
encryptedText = encryptedText & swapletters(charactercode)
End If
Next
Return encryptedText
End Function
Private Function DecryptText(str As String) As String
Dim swapletters As New List(Of String) From {"l", "s", "d", "f", "g", "h", "j", "k", "a", "q", "w", "e", "r", "t", "y", "u", "i", "o", "p", "z", "x", "c", "v", "b", "n", "m"}
Dim decryptedText As String = ""
For Each letter As Char In str
If letter = " "c Then
decryptedText = decryptedText & " "
Else
Dim character As String = Chr(swapletters.IndexOf(letter) + 97)
decryptedText = decryptedText & character
End If
Next
Return decryptedText
End Function
To use them, declare a string to hold the return value of each function
Dim etext As String
etext = EncryptText("disambiguation is the root of all evil")
results in etext being "faplrsajxlzayt ap zkg oyyz yh lee gcae"
and
Dim dtext As String
dtext = DecryptText("faplrsajxlzayt ap zkg oyyz yh lee gcae")
results in "disambiguation is the root of all evil"
What is the VBA string interpolation syntax? Does it exist?
I would to to use Excel VBA to format a string.
I have a variable foo that I want to put in a string for a range.
Dim row as Long
row = 1
myString = "$row:$row"
I would like the $row in the string to be interpolated as "1"
You could also build a custom Format function.
Public Function Format(ParamArray arr() As Variant) As String
Dim i As Long
Dim temp As String
temp = CStr(arr(0))
For i = 1 To UBound(arr)
temp = Replace(temp, "{" & i - 1 & "}", CStr(arr(i)))
Next
Format = temp
End Function
The usage is similar to C# except that you can't directly reference variables in the string. E.g. Format("This will {not} work") but Format("This {0} work", "will").
Public Sub Test()
Dim s As String
s = "Hello"
Debug.Print Format("{0}, {1}!", s, "World")
End Sub
Prints out Hello, World! to the Immediate Window.
This works well enough, I believe.
Dim row as Long
Dim s as String
row = 1
s = "$" & row & ":$" & row
Unless you want something similar to Python's or C#'s {} notation, this is the standard way of doing it.
Using Key\Value Pairs
Another alternative to mimic String interpolation is to pass in key\value pairs as a ParamArray and replace the keys accordingly.
One note is that an error should be raised if there are not an even number of elements.
' Returns a string that replaced special keys with its associated pair value.
Public Function Inject(ByVal source As String, ParamArray keyValuePairs() As Variant) As String
If (UBound(keyValuePairs) - LBound(keyValuePairs) + 1) Mod 2 <> 0 Then
Err.Raise 5, "Inject", "Invalid parameters: expecting key/value pairs, but received an odd number of arguments."
End If
Inject = source
' Replace {key} with the pairing value.
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
Inject = Replace(Inject, "{" & keyValuePairs(index) & "}", keyValuePairs(index + 1), , , vbTextCompare)
Next index
End Function
Simple Example
Here is a simple example that shows how to implement it.
Private Sub testingInject()
Const name As String = "Robert"
Const age As String = 31
Debug.Print Inject("Hello, {name}! You are {age} years old!", "name", name, "age", age)
'~> Hello, Robert! You are 31 years old!
End Sub
Although this may add a few extra strings, in my opinion, this makes it much easier to read long strings.
See the same simple example using concatenation:
Debug.Print "Hello, " & name & "! You are " & age & " years old!"
Using Scripting.Dicitionary
Really, a Scripting.Dictionary would be perfect for this since they are nothing but key/value pairs. It would be a simple adjustment to my code above, just take in a Dictionary as the parameter and make sure the keys match.
Public Function Inject(ByVal source As String, ByVal data As Scripting.Dictionary) As String
Inject = source
Dim key As Variant
For Each key In data.Keys
Inject = Replace(Inject, "{" & key & "}", data(key))
Next key
End Function
Dictionary example
And the example of using it for dictionaries:
Private Sub testingInject()
Dim person As New Scripting.Dictionary
person("name") = "Robert"
person("age") = 31
Debug.Print Inject("Hello, {name}! You are {age} years old!", person)
'~> Hello, Robert! You are 31 years old!
End Sub
Additional Considerations
Collections sound like they would be nice as well, but there is no way of accessing the keys. It would probably get messier that way.
If using the Dictionary method you might create a simple factory function for easily creating Dictionaries. You can find an example of that on my Github Library Page.
To mimic function overloading to give you all the different ways you could create a main Inject function and run a select statement within that.
Here is all the code needed to do that if need be:
Public Function Inject(ByVal source As String, ParamArray data() As Variant) As String
Dim firstElement As Variant
assign firstElement, data(LBound(data))
Inject = InjectCharacters(source)
Select Case True
Case TypeName(firstElement) = "Dictionary"
Inject = InjectDictionary(Inject, firstElement)
Case InStr(source, "{0}") > 0
Inject = injectIndexes(Inject, CVar(data))
Case (UBound(data) - LBound(data) + 1) Mod 2 = 0
Inject = InjectKeyValuePairs(Inject, CVar(data))
Case Else
Err.Raise 5, "Inject", "Invalid parameters: expecting key/value pairs or Dictionary or an {0} element."
End Select
End Function
Private Function injectIndexes(ByVal source As String, ByVal data As Variant)
injectIndexes = source
Dim index As Long
For index = LBound(data) To UBound(data)
injectIndexes = Replace(injectIndexes, "{" & index & "}", data(index))
Next index
End Function
Private Function InjectKeyValuePairs(ByVal source As String, ByVal keyValuePairs As Variant)
InjectKeyValuePairs = source
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
InjectKeyValuePairs = Replace(InjectKeyValuePairs, "{" & keyValuePairs(index) & "}", keyValuePairs(index + 1))
Next index
End Function
Private Function InjectDictionary(ByVal source As String, ByVal data As Scripting.Dictionary) As String
InjectDictionary = source
Dim key As Variant
For Each key In data.Keys
InjectDictionary = Replace(InjectDictionary, "{" & key & "}", data(key))
Next key
End Function
' QUICK TOOL TO EITHER SET OR LET DEPENDING ON IF ELEMENT IS AN OBJECT
Private Function assign(ByRef variable As Variant, ByVal value As Variant)
If IsObject(value) Then
Set variable = value
Else
Let variable = value
End If
End Function
End Function
Private Function InjectCharacters(ByVal source As String) As String
InjectCharacters = source
Dim keyValuePairs As Variant
keyValuePairs = Array("n", vbNewLine, "t", vbTab, "r", vbCr, "f", vbLf)
If (UBound(keyValuePairs) - LBound(keyValuePairs) + 1) Mod 2 <> 0 Then
Err.Raise 5, "Inject", "Invalid variable: expecting key/value pairs, but received an odd number of arguments."
End If
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Global = True
' Replace is ran twice since it is possible for back to back patterns.
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
RegEx.Pattern = "((?:^|[^\\])(?:\\{2})*)(?:\\" & keyValuePairs(index) & ")+"
InjectCharacters = RegEx.Replace(InjectCharacters, "$1" & keyValuePairs(index + 1))
InjectCharacters = RegEx.Replace(InjectCharacters, "$1" & keyValuePairs(index + 1))
Next index
End Function
I have a library function SPrintF() which should do what you need.
It replaces occurrences of %s in the supplied string with an extensible number of parameters, using VBA's ParamArray() feature.
Usage:
SPrintF("%s:%s", 1, 1) => "1:1"
SPrintF("Property %s added at %s on %s", "88 High St, Clapham", Time, Date) => ""Property 88 High St, Clapham added at 11:30:27 on 25/07/2019"
Function SprintF(strInput As String, ParamArray varSubstitutions() As Variant) As String
'Formatted string print: replaces all occurrences of %s in input with substitutions
Dim i As Long
Dim s As String
s = strInput
For i = 0 To UBound(varSubstitutions)
s = Replace(s, "%s", varSubstitutions(i), , 1)
Next
SprintF = s
End Function
Just to add as a footnote, the idea for this was inspired by the C language printf function.
I use a similar code to that of #natancodes except that I use regex to replace the occurances and allow the user to specifiy description for the placeholders. This is useful when you have a big table (like in Access) with many strings or translations so that you still know what each number means.
Function Format(ByVal Source As String, ParamArray Replacements() As Variant) As String
Dim Replacement As Variant
Dim i As Long
For i = 0 To UBound(Replacements)
Dim rx As New RegExp
With rx
.Pattern = "{" & i & "(?::(.+?))?}"
.IgnoreCase = True
.Global = True
End With
Select Case VarType(Replacements(i))
Case vbObject
If Replacements(i) Is Nothing Then
Dim Matches As MatchCollection
Set Matches = rx.Execute(Source)
If Matches.Count = 1 Then
Dim Items As SubMatches: Set Items = Matches(0).SubMatches
Dim Default As String: Default = Items(0)
Source = rx.Replace(Source, Default)
End If
End If
Case vbString
Source = rx.Replace(Source, CStr(Replacements(i)))
End Select
Next
Format = Source
End Function
Sub TestFormat()
Debug.Print Format("{0:Hi}, {1:space}!", Nothing, "World")
End Sub
This post is half to share a solution and half to ask if there's a better way to do it.
Problem: how to build a multi-dimensional dictionary in VBA.
It seems there are people out there looking for one, but there isn't an obvious neat solution around so I came up with some code, as follows.
Specific case: convert an ADO Recordset into a Dictionary, where several columns comprise the unique key for a row. Adding multiple records to the same Dictionary fails unless you come up with a key that concatenates all the columns that comprise the unique key.
General case: model a tree structure in an object hierarchy where there might not be the same number of branches across every node at the same level in the hierarchy.
The code below solves both problems. Performance untested but the VBA Scripting library's Dictionary class is apparently indexed with a hash table and I've seen very large systems built with it, so I doubt performance will be an issue. Maybe one of the giant brains out there will correct me on this.
Put this into a VBA class called multiDictionary:
Option Explicit
' generic multi-dimensional dictionary class
' each successive higher dimension dictionary is nested within a lower dimension dictionary
Private pDictionary As Dictionary
Private pDimensionKeys() As Variant
Private Const reservedItemName As String = "multiItem"
Public Function add(value As Variant, ParamArray keys() As Variant)
Dim searchDictionary As Dictionary
Dim newDictionary As Dictionary
Dim count As Long
If pDictionary Is Nothing Then Set pDictionary = New Dictionary
Set searchDictionary = pDictionary
For count = LBound(keys) To UBound(keys)
If keys(count) = reservedItemName Then Err.Raise -1, "multiDictionary.add", "'" & reservedItemName & "' is a reserved key and cannot be used"
If searchDictionary.Exists(keys(count)) Then
Set newDictionary = searchDictionary.item(keys(count))
Else
Set newDictionary = New Dictionary
searchDictionary.add key:=keys(count), item:=newDictionary
End If
Set searchDictionary = searchDictionary.item(keys(count))
Next
' each node can have only one item, otherwise it has dictionaries as children
searchDictionary.add item:=value, key:=reservedItemName
End Function
Public Function item(ParamArray keys() As Variant) As Variant
Dim count As Long
Dim searchDictionary As Dictionary
Set searchDictionary = pDictionary
For count = LBound(keys) To UBound(keys)
' un-nest iteratively
Set searchDictionary = searchDictionary.item(keys(count))
Next
' the item always has the key 'reservedItemName' (by construction)
If IsObject(searchDictionary.item(reservedItemName)) Then
Set item = searchDictionary.item(reservedItemName)
Else
item = searchDictionary.item(reservedItemName)
End If
End Function
And test it like this
Sub testMultiDictionary()
Dim MD As New multiDictionary
MD.add "Blah123", 1, 2, 3
MD.add "Blah124", 1, 2, 4
MD.add "Blah1234", 1, 2, 3, 4
MD.add "BlahXYZ", "X", "Y", "Z"
MD.add "BlahXY3", "X", "Y", 3
Debug.Print MD.item(1, 2, 3)
Debug.Print MD.item(1, 2, 4)
Debug.Print MD.item(1, 2, 3, 4)
Debug.Print MD.item("X", "Y", "Z")
Debug.Print MD.item("X", "Y", 3)
End Sub