'=======================================================
'ReplaceAndSplit2 is based on the alainbryden routine
'Uses the native REPLACE() function to replace all delimiters with a common
'delimiter, and then splits the modified string on that delimiter.
'=======================================================
Function ReplaceAndSplit2(ByRef parmText As String, _
ByRef parmDelimiters As String) As String()
Dim DelimCount As Long, DelimLoop As Long
Dim strDelims() As String
Dim strTemp As String, Delim1 As String
Dim ThisDelim As String
strTemp = parmText
strDelims = Split(Mid(parmDelimiters, 2), Mid(parmDelimiters, 1, 1))
Delim1 = parmDelimiters(0)
DelimCount = UBound(strDelims)
For DelimLoop = 1 To DelimCount
ThisDelim = strDelims(DelimLoop)
If InStr(strTemp, ThisDelim) <> 0 Then _
strTemp = Replace(strTemp, ThisDelim, Delim1)
Next DelimLoop
ReplaceAndSplit2 = Split(strTemp, Delim1)
End Function
Usage: If we wanted to parse a web page's HTML to get the link data, we might invoke this routine with:
Dim strHTML() As String
Dim strLinks() As String
Dim lngLoop As Long, lngLink As Long
strHTML = ReplaceAndSplit2(strPageContents, "\<a \</a>")
ReDim strLinks(1 To UBound(strHTML)\2)
For lngLoop = 1 To UBound(strHTML) Step 2
lngLink = lngLink + 1
strLinks(lngLink) = strHTML(lngLoop)
Next
Pretty slick, eh? By passing a delimited string of delimiters (sub-strings) we are now able to parse a string with a list of multi-character delimiters. With this one change, we now allow our custom parsing function to behave much more like repeated applications of the Split() function. But, there's more&
Array("<a ", "</a>", "img src=", "href=", _
"<form ", "</form>")
Dim Delims() As Variant
Delims = Array("<a ", "</a>")
Delims = Split(Join(Delims,"^") & "^" & "img src=" & "^" & "href=","^")
Delims = Split(Join(Delims,"^") & "^" & "<form " & "^" & "</form>", "^")
'To see the contents of Delims, run the following:
Dim D As Long
For D = 0 To UBound(Delims)
Debug.Print D, Delims(D)
Next
Dim Ex() As Variant
Ex = Array(Array(1,"Mark",#2/3/2009#), Array(2,"Fred",#3/4/2009#))
'To see the contents of Ex, run the following:
Dim D As Long
For D = 0 To UBound(Ex)
Debug.Print D, Ex(D)(0) , Ex(D)(1) , Ex(D)(2)
Next
'=======================================================
'ReplaceAndSplit3 is based on the alainbryden routine
'Uses the native REPLACE() function to replace all delimiters with a common
'delimiter, and then splits the modified string on that delimiter.
'=======================================================
Function ReplaceAndSplit3(ByRef parmText As String, _
parmDelimiters() As Variant) As String()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Expected format of parmDelimiters array:
' Each row contains three element array (indexes = 0,1,2)
' = delimstring, count, stringcomparetype
'Note: default count = -1 and the default stringcomparetype = 0
' See the Replace function documentation in the appendix for
' more information.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim DelimCount As Long, DelimLoop As Long
Dim strTemp As String
Dim Delim1() As Variant
Dim ThisDelim() As Variant
strTemp = parmText
Delim1 = parmDelimiters(0)
DelimCount = UBound(parmDelimiters)
For DelimLoop = 1 To DelimCount
ThisDelim = parmDelimiters(DelimLoop)
If InStr(strTemp, ThisDelim(0)) <> 0 Then _
strTemp = Replace(strTemp, ThisDelim(0), Delim1(0), 1, ThisDelim(1), ThisDelim(2))
Next DelimLoop
ReplaceAndSplit3 = Split(strTemp, Delim1(0), Delim1(1), Delim1(2))
End Function
Usage: If we wanted to parse a web page into the header and the first 5 name anchors, we might invoke this routine with:
Dim strHTML() As String
strHTML = ReplaceAndSplit3(strPageContents, _
Array(Array("<head>", -1, 0), Array("</head>", -1, 0), _
Array("<a name=", 5, 0)))
Dim colEarlyBind As New Collection
Dim colLateBind As Collection
Set colLateBind = New Collection
Dim colEarlyBind As New Collection
colEarlyBind.Add "<a "
colEarlyBind.Add "</a>"
colEarlyBind.Add "img src="
colEarlyBind.Add "href="
colEarlyBind.Add "<form "
colEarlyBind.Add "</form>"
Dim dicEarlyBind As New Scripting.Dictionary
Dim dicLateBind As Object
Set dicLateBind = CreateObject("Scripting.Dictionary")
Dim dicEarlyBind As New Scripting.Dictionary
dicEarlyBind.Add 1,"<a "
dicEarlyBind.Add 2,"</a>"
dicEarlyBind.Add 3,"img src="
dicEarlyBind.Add 4,"href="
dicEarlyBind.Add 5,"<form "
dicEarlyBind.Add 6,"</form>"
'=======================================================
'ReplaceAndSplit4 is based on the alainbryden routine
'Uses the native REPLACE() function to replace all delimiters with a common
'delimiter, and then splits the modified string on that delimiter.
'=======================================================
Function ReplaceAndSplit4(ByRef parmText As String, _
parmDelimiters As Variant) As String()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'parmDelimiters is expected to be a collection or dictionary.
'Note: Since the default item is iterated by the For Each statement
' below, the dictionary delimiters should be assigned to the
' key values since those are the default items.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim strTemp As String
Dim Delim1 As Variant
Dim ThisDelim As Variant
strTemp = parmText
For Each ThisDelim In parmDelimiters
If IsEmpty(Delim1) Then
Delim1 = ThisDelim
Else
If InStr(strTemp, ThisDelim) <> 0 Then _
strTemp = Replace(strTemp, ThisDelim, Delim1)
End If
Next
ReplaceAndSplit4 = Split(strTemp, Delim1)
End Function
Dim dicDelim As New Scripting.Dictionary
Dim strParsed() As String
dicDelim.Add "(", 1
dicDelim.Add ")", 1
strParsed = ReplaceAndSplit4("WHERE (HireDate Between #4/1/2000# And #4/1/2009#) And (Cat Like 'PROD*')", dicDelim)
'=======================================================
'UpdateRecord accepts key/item (field name/value) pairs through
' a dictionary parameter, a recordset, and key value.
'=======================================================
Function UpdateRecord(parmRS As Recordset, _
parmID As Long _
parmNewValues As Variant) As Long
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'parmRS is a recordset
'parmID is the ID (autonumber) value
'parmNewValues is expected to be a dictionary
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim vFieldname As Variant
Dim lngError As Long
On Error Resume Next
parmRS.Find "ID=" & parmID
parmRS.Edit
For Each vFieldname In parmNewValues
parmRS.Fields(vFieldname) = parmNewValues(vFieldname)
If Err <> 0 Then
lngError = Err
Exit For
End If
Next
If lngError = 0 Then
parmRS.Update
Else
parmRS.CancelUpdate
End If
UpdateRecord = lngError 'Return any error value
End Function
Dim dicDataChgs As New Scripting.Dictionary
Dim lngRC As Long
dicDataChgs.Add "VisitDate", #4/1/2008#
dicDataChgs.Add "AgeAtEncounter", 55
dicDataChgs.Add "CD4Count", 780
dicDataChgs.Add "ARTname", "Kaletra"
dicDataChgs.Add "HemoFactorType", Null
lngRC = UpdateRecord(rsClinData, 2525, dicDataChgs)
'=======================================================
'UpdateRecords accepts key/item (field name/value) pairs through
' a dictionary parameter, and a recordset.
'=======================================================
Function UpdateRecords(parmRS As Recordset, _
parmNewValues As Variant) As Collection
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'parmRS is a recordset
'parmNewValues is expected to be a dictionary of dictionary objects.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim vFieldname As Variant
Dim vRow As Variant
Dim lngError As Long
Dim colErrors As New Collection
On Error Resume Next
For Each vRow In parmNewValues
parmRS.Find "ID=" & vRow
parmRS.Edit
For Each vFieldname In parmNewValues(vRow)
parmRS.Fields(vFieldname) = parmNewValues(vRow)(vFieldname)
If Err <> 0 Then
lngError = Err
Exit For
End If
Next
If lngError = 0 Then
parmRS.Update
Else
parmRS.CancelUpdate
End If
colErrors.Add CStr(lngError) 'Return any error values
Next 'Row change
Set UpdateRecords = colErrors
End Function
Dim dicDataChgs As New Scripting.Dictionary
Dim dicRowChgs As New Scripting.Dictionary
Dim colErrors As New Collection
dicDataChgs.Add "VisitDate", #4/1/2008#
dicDataChgs.Add "AgeAtEncounter", 55
dicDataChgs.Add "CD4Count", 780
dicDataChgs.Add "ARTname", "Kaletra"
dicDataChgs.Add "HemoFactorType", Null
dicRowChgs.Add 2525, dicDataChgs
Set dicDataChgs = New Scripting.Dictionary 'new instance
dicDataChgs.Add "VisitDate", #5/15/2008#
dicDataChgs.Add "AgeAtEncounter", 19
dicDataChgs.Add "HemoFactorType", "VIII"
dicRowChgs.Add 42, dicDataChgs
Set colErrors = UpdateRecords(rsClinData, dicRowChgs)
'=======================================================
'FileActions performs actions on files
'=======================================================
Function FileActions(parmActions As Collection) As Collection
Dim clsAction As MyActionClass
Dim colErrors As New Collection
On Error Resume Next
For Each clsAction In parmActions
Select Case clsAction.Action
Case ActionEnums.Copy
FileCopy clsAction.Value, clsAction.NewValue
Case ActionEnums.Delete
Kill clsAction.Value
Case ActionEnums.Move
FileCopy clsAction.Value, clsAction.NewValue
Kill clsAction.Value
Case ActionEnums.Rename
Name clsAction.Value As clsAction.NewValue
End Select
colErrors.Add CStr(Err) 'Return any error values
If Err <> 0 Then
Err.Clear
End If
Next
Set FileActions = colErrors
End Function
Usage: In this scenario, I create three class objects to rename, copy and delete some files. I've done something similar in one of my commercial applications. I might need to send an encrypted file to a user to correct some application or licensing problem. After decrypting the file, I process the individual actions supplied. In this example, the actions and other properties are being set from literals instead of from an external source.
Dim clsX As MyActionClass
Dim colActions As New Collection
Dim colErrors As New Collection
Dim vError As Variant
Set clsX = New MyActionClass
With clsX
.Action = Rename
.Value = "C:\Temp\Old.txt"
.NewValue = "C:\Temp\New.txt"
End With
colActions.Add clsX
Set clsX = Nothing
Set clsX = New MyActionClass
With clsX
.Action = Copy
.Value = "C:\Temp\New.txt"
.NewValue = "C:\Temp2\NewCopy.txt"
End With
colActions.Add clsX
Set clsX = Nothing
Set clsX = New MyActionClass
With clsX
.Action = Delete
.Value = "C:\Temp\New.txt"
End With
colActions.Add clsX
Set colErrors = FileActions(colActions)
'Display the error collection in the Immediate window
For Each vError In colErrors
Debug.Print vError, Error(vError)
Next
The class module. I make this as simple as I could, but keep it non-trivial.
Option Explicit
Public Enum ActionEnums
Rename = 1
Delete = 2
Copy = 4
Move = 8
End Enum
Public Action As ActionEnums
Private strValue As String
Private strNewValue As String
Public Property Get Value() As Variant
Value = strValue
End Property
Public Property Let Value(ByVal vNewValue As Variant)
strValue = vNewValue
End Property
Public Property Get NewValue() As Variant
NewValue = strNewValue
End Property
Public Property Let NewValue(ByVal vNewValue As Variant)
strNewValue = vNewValue
End Property
Sub ListNodes(parmXMLdoc As DOMDocument)
Dim xElement As IXMLDOMElement
Dim xElement2 As IXMLDOMElement
For Each xElement In parmXMLdoc.childNodes(1).childNodes
Debug.Print xElement.getAttribute("Name")
For Each xElement2 In xElement.childNodes
Debug.Print , xElement2.nodeName, xElement2.Text
Next
Debug.Print "__________________"
Next
End Sub
Dim xDoc As New DOMDocument
xDoc.Load "C:\Users\AikiMark\Documents\test.xml"
ListNodes xDoc
The test.XML document contents.
<?xml version="1.0" encoding="utf-8"?>
<Houses>
<House Name="Mark">
<Color>Carolina Blue</Color>
<Addr>14 Flagon O Mead Ct</Addr>
<City>Durham</City>
<State>NC</State>
<Zip>27714</Zip>
</House>
<House Name="Fred">
<Color>Red Brick</Color>
<Addr>2610 Flintstone Blvd</Addr>
<City>Tullahoma</City>
<State>TN</State>
<Zip>98898</Zip>
</House>
</Houses>
Public Sub UniqueValues()
Dim rngOriginal As Range
Dim rngUnique As Range
Dim dicUniqueValues As Scripting.Dictionary
Dim vUnique As Variant
Dim lngOffset As Long
Const cIBtype_Range As Long = 8
Set rngOriginal = Application.InputBox("Select range of values", _
"Range Prompt", Type:=cIBtype_Range)
Set rngUnique = Application.InputBox("Select starting location for unique values", _
"Unique Start Prompt", Type:=cIBtype_Range)
Set dicUniqueValues = GetUniqueValues(rngOriginal)
Application.
Application.ScreenUpdating = False 'for better performance
For Each vUnique In dicUniqueValues
rngUnique.Offset(lngOffset, 0) = vUnique
lngOffset = lngOffset + 1
Next
Application.ScreenUpdating = True
End Sub
Public Function GetUniqueValues(parmRng As Range) As Scripting.Dictionary
Dim dicUnique As New Scripting.Dictionary
Dim rngCell As Range
For Each rngCell In parmRng
If dicUnique.Exists(rngCell.Value) Then
Else
dicUnique.Add rngCell.Value, 1
End If
Next
Set GetUniqueValues = dicUnique
Set dicUnique = Nothing
End Function
Public Sub UniqueValuesFast()
Dim rngOriginal As Range
Dim rngUnique As Range
Dim vArray() As Variant
Const cIBtype_Range As Long = 8
Set rngOriginal = Application.InputBox("Select range of values", _
"Range Prompt", Type:=cIBtype_Range)
Set rngUnique = Application.InputBox("Select starting location for unique values", _
"Unique Start Prompt", Type:=cIBtype_Range)
vArray = GetUniqueValues(rngOriginal).Keys
Application.ScreenUpdating = False 'for better performance
rngUnique.Worksheet.Range(rngUnique.Address, rngUnique.Offset(UBound(vArray), 0)) = _
Application.WorksheetFunction.Transpose(vArray)
Application.ScreenUpdating = True
End Sub
Parameter Description
String The string to be searched
Findstring The searched-for string -- will be replaced
Replacewith The replacement string
Start Optional. Specifies the start position -- Default = 1
Count Optional. Specifies the number of substitutions to perform. The default value is -1, which causes replacement of all the Findstring values
Compare Optional. Specifies the type of comparison to use, case-sensitive or case-insensitive. The default is 0 (case sensitive) which performs faster.
Can be one of the following values:
0 = vbBinaryCompare - Perform a binary comparison
1 = vbTextCompare
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (3)
Author
Commented:In the class object example
colErrors.Add CStr(Err)
would probably be simpler if written as
colErrors.Add Err.Number
Commented:
Mario
Lima- Perú
Author
Commented:Do a search of articles and you should find an article about passing a complex parameter to a stored procedure in the form of XML or a delimited list. This article only concerns itself with passing complex parameters to VB/VBA routines.