What can you learn here?

  • Make a tag cloud in Outlook
  • cJobject as ‘on demand’
  • Read lots of mail at once

Making a tag Cloud in Outlook

Here is an example of how to implement a tag cloud class. Once you have implemented a tagCloud in Outlook you can ‘get the flavor and main messages’ of multiple selected mails without having to read them.

 

What to download

There is no download for this – the code is in the write up below, and you can just copy and paste it into your outlook project. For How to create a tag cloud in excel download cDataSet.xlsm from Download Complete Projects 

An example

 In this example we are going to adapt How to create a tag cloud for Excel to create a similar capability for Outlook. Here’s an example

  • Select a collection of emails from outlook
  • Run the procedure, and it will generate a new mailItem, containing the tagCloud for the contents of the selected mails

The code

Normally the code on this site is for Excel, but in this case, I’ve have created this for Outlook directly. Up to you how you invoke it, but I added it to a toolbar, and find it very useful – here is how  To implement this in outlook you will need to create a few class modules and modules and paste in the code that follows. You will also need a reference to the VBScript regular expressions library since I use the Regular Expressions module from this site.  

Tweaking

You can use the code as-is, but you may want to tweak the behavior. In principle, it works the same way as How to create a tag cloud in Excel, but with a few different options by default. In the testTagItems procedure, the default tagCloud init behavior is changed by

  • modifying the minimum number of hits to be reported to be based on the number of mail items. In this case, the minimum is 3 + 25% of the number of items included in the analysis.
  • The minimum and maximum font sizes are set to 12px – 60px.
mn = 3
    With Application.ActiveExplorer.Selection
        tg.init "tagCloud created on " & Now & " with " & .Count & " mailitems", , _
        mn + 0.25 * .Count, " ", , , 12, 60

Add Speech

If you want, you can Use Microsoft Speech (you need to add another reference) to have your tag cloud read out – (say .Body)

 

With mailItem
        .Subject = tg.tagJob.key
        .BodyFormat = olFormatHTML
        .HTMLBody = tg.htmlResults
        .Display (False)
        say .Body
    End With

HTML

Note that the report is created as an html formatted mail. if you want to instead create a web page, you can just use the string returned by htmlResults to publish to a web page instead of a mailItem. 

.HTMLBody = tg.htmlResults

Here’s the modules and class modules to create

  And the code is below for each of these modules – not all of it is needed right now, but I copied over the modules from the corresponding Excel modules. 

RegXlib

Option Explicit
'for more about this
' https://ramblings.mcpher.com/classes/datamanip/
'to contact me
' http://groups.google.com/group/excel-ramblings
'reuse of code
' https://ramblings.mcpher.com/reusing-code-from-this-site/
Public Function rxString(sName As String, s As String, Optional ignorecase As Boolean = True) As String
Dim rx As cregXLib
' create a new regx
Set rx = rxMakeRxLib(sName)
rx.ignorecase = ignorecase
' extract the string that matches the requested pattern
rxString = rx.getString(s)

End Function
Public Function rxTest(sName As String, s As String, Optional ignorecase As Boolean = True) As Boolean
Dim rx As cregXLib
' create a new regx
Set rx = rxMakeRxLib(sName)
rx.ignorecase = ignorecase
' extract the string that matches the requested pattern
rxTest = rx.getTest(s)

End Function
Public Function rxReplace(sName As String, sFrom As String, sTo As String, Optional ignorecase As Boolean = True) As String
Dim rx As cregXLib
' create a new regx
Set rx = rxMakeRxLib(sName)
rx.ignorecase = ignorecase
' replace the string that matches the requested pattern
rxReplace = rx.getReplace(sFrom, sTo)

End Function
Public Function rxPattern(sName As String) As String
Dim rx As cregXLib
' create a new regx
Set rx = rxMakeRxLib(sName)
' just returnthe pattern
rxPattern = rx.Pattern

End Function
Function rxMakeRxLib(sName As String) As cregXLib
Dim rx As cregXLib, s As String
Set rx = New cregXLib
' normally sname points to a preselected regEX
' if not known, silently assume its a regex pattern
s = Replace(UCase(sName), " ", "")
Select Case s
Case "POSTALCODEUK"
rx.init s, _
"(((^[BEGLMNS][1-9]\d?) | (^W[2-9] ) | ( ^( A[BL] | B[ABDHLNRST] | C[ABFHMORTVW] | D[ADEGHLNTY] | E[HNX] | F[KY] | G[LUY] | H[ADGPRSUX] | I[GMPV] |" & _
" JE | K[ATWY] | L[ADELNSU] | M[EKL] | N[EGNPRW] | O[LX] | P[AEHLOR] | R[GHM] | S[AEGKL-PRSTWY] | T[ADFNQRSW] | UB | W[ADFNRSV] | YO | ZE ) \d\d?) |" & _
" (^W1[A-HJKSTUW0-9]) | (( (^WC[1-2]) | (^EC[1-4]) | (^SW1) ) [ABEHMNPRVWXY] ) ) (\s*)? ([0-9][ABD-HJLNP-UW-Z]{2})) | (^GIR\s?0AA)"

Case "POSTALCODESPAIN"
rx.init s, _
"^([1-9]{2}|[0-9][1-9]|[1-9][0-9])[0-9]{3}$"

Case "PHONENUMBERUS"
rx.init s, _
"^\(?(?<AreaCode>[2-9]\d{2})(\)?)(-|.|\s)?(?<Prefix>[1-9]\d{2})(-|.|\s)?(?<Suffix>\d{4})$"

Case "CREDITCARD" 'amex/visa/mastercard
rx.init s, _
"^((4\d{3})|(5[1-5]\d{2}))(-?|\040?)(\d{4}(-?|\040?)){3}|^(3[4,7]\d{2})(-?|\040?)\d{6}(-?|\040?)\d{5}"

Case "NUMERIC"
rx.init s, _
"[\0-9]"

Case "ALPHABETIC"
rx.init s, _
"[\a-zA-Z]"

Case "NONNUMERIC"
rx.init s, _
"[^\0-9]"

Case "IPADDRESS"
rx.init s, _
"^(\d{1,2}|1\d\d|2[0-4]\d|25[0-5])\.(\d{1,2}|1\d\d|2[0-4]\d|25[0-5])\.(\d{1,2}|1\d\d|2[0-4]\d|25[0-5])\.(\d{1,2}|1\d\d|2[0-4]\d|25[0-5])$"

Case "SINGLESPACE" ' should take a replace value of "$1 "
rx.init s, _
"(\S )\x20{2,}(?=\S )"

Case "EMAIL"
rx.init s, _
"^[A-Z0-9._% -] @[A-Z0-9.-] \.[A-Z]{2,4}$"

Case "EMAILINSIDE"
rx.init s, _
"\b[A-Z0-9._% -] @[A-Z0-9.-] \.[A-Z]{2,4}\b"

Case "NONPRINTABLE"
rx.init s, "[\x00-\x1F\x7F]"


Case "PUNCTUATION"
rx.init s, "[^A-Za-z0-9\x20] "

Case Else
rx.init "Adhoc", sName

End Select

Set rxMakeRxLib = rx
End Function

TestTagItems

Option Explicit
' create a tag cloud from selected mail items

Public Sub selTagItems()
Dim i As Long, tg As cTagCloud, mn As Long
Dim mailItem As Outlook.mailItem
Set tg = New cTagCloud
mn = 3

With Application.ActiveExplorer.Selection

tg.init "tagCloud created on " & Now & " with " & .Count & " mailitems", , _
mn 0.25 * .Count, " ", , , 12, 60
For i = 1 To .Count
With .Item(i)
tg.collect CStr(.Body)
End With
Next i
End With
' put the results out to a new mail item
Set mailItem = Application.CreateItem(Outlook.OlItemType.olMailItem)
With mailItem
.Subject = tg.tagJob.key
.BodyFormat = olFormatHTML
.HTMLBody = tg.htmlResults
.Display (False)
End With
Set tg = Nothing
End Sub

UsefulStuff

Option Explicit
' note original execute shell stuff came from this post
' http://stackoverflow.com/questions/3166265/open-an-html-page-in-default-browser-with-vba
' thanks to http://stackoverflow.com/users/174718/dmr
Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal Operation As String, _
ByVal Filename As String, _
Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMaximizedFocus _
) As Long
' note Acknowledgement URI encode stuff came from this post
' http://stackoverflow.com/questions/218181/how-can-i-url-encode-a-string-in-excel-vba
' thanks to http://stackoverflow.com/users/4023/matthew-murdoch
Private Const CP_UTF8 = 65001
Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
ByVal CodePage As Long, ByVal dwflags As Long, _
ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

Public Const cFailedtoGetHandle = -1
Public Function OpenUrl(url) As Boolean
Dim lSuccess As Long
lSuccess = ShellExecute(0, "Open", url)
OpenUrl = lSuccess > 32
End Function




Public Function UTF16To8(ByVal UTF16 As String) As String
Dim sBuffer As String
Dim lLength As Long
If UTF16 <> "" Then
lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
sBuffer = Space$(lLength)
lLength = WideCharToMultiByte( _
CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
sBuffer = StrConv(sBuffer, vbUnicode)
UTF16To8 = Left$(sBuffer, lLength - 1)
Else
UTF16To8 = ""
End If
End Function

Public Function URLEncode( _
StringVal As String, _
Optional SpaceAsPlus As Boolean = False, _
Optional UTF8Encode As Boolean = True _
) As String

Dim StringValCopy As String: StringValCopy = _
IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
Dim StringLen As Long: StringLen = Len(StringValCopy)

If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String

If SpaceAsPlus Then Space = " " Else Space = " "

For i = 1 To StringLen
Char = Mid$(StringValCopy, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = Space
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")

End If
End Function

' sort a collection
Function SortColl(ByRef coll As Collection, eorder As Long) As Long
Dim ita As Long, itb As Long
Dim va As Variant, vb As Variant, bSwap As Boolean
Dim x As Object, y As Object

For ita = 1 To coll.Count - 1
For itb = ita 1 To coll.Count
Set x = coll(ita)
Set y = coll(itb)
bSwap = x.needSwap(y, eorder)
If bSwap Then
With coll
Set va = coll(ita)
Set vb = coll(itb)
.add va, , itb
.add vb, , ita
.Remove ita 1
.Remove itb 1
End With
End If
Next
Next
End Function
Public Function getHandle(sName As String) As Integer
Dim hand As Integer
On Error GoTo handleError
hand = FreeFile
Open sName For Output As hand
getHandle = hand
Exit Function

handleError:
MsgBox ("Could not create file " & sName)
getHandle = cFailedtoGetHandle
End Function
Function afConcat(arr() As Variant) As String
Dim i As Long, s As String
s = ""
For i = LBound(arr) To UBound(arr)
s = s & arr(i, 1) & "|"
Next i
afConcat = s
End Function
Public Function quote(s As String) As String
quote = q & s & q
End Function
Public Function q() As String
q = Chr(34)
End Function
Public Function qs() As String
qs = Chr(39)
End Function
Public Function bracket(s As String) As String
bracket = "(" & s & ")"
End Function
Public Function list(ParamArray args() As Variant) As String
Dim i As Long, s As String
s = vbNullString
For i = LBound(args) To UBound(args)
If s <> vbNullString Then s = s & ","
s = s & CStr(args(i))
Next i
list = s
End Function

Public Function qlist(ParamArray args() As Variant) As String
Dim i As Long, s As String
s = vbNullString
For i = LBound(args) To UBound(args)
If s <> vbNullString Then s = s & ","
s = s & quote(CStr(args(i)))
Next i
qlist = s
End Function
Public Function diminishingReturn(val As Double, Optional s As Double = 10) As Double
diminishingReturn = Sgn(val) * s * (Sqr(2 * (Sgn(val) * val / s) 1) - 1)
End Function

Public Sub say(sTerm As String)
Dim spv As Object
Set spv = CreateObject("SAPI.SpVoice")
spv.Speak sTerm
Set spv = Nothing
End Sub

Public Function heatMapColor(min As Variant, _
max As Variant, Value As Variant, _
Optional intensityRed As Double = 1#, _
Optional intensityGreen As Double = 1#, _
Optional intensityBlue As Double = 1#, _
Optional intensityRamp As Double = 1#) As Long

Dim spread As Double, ratio As Double, red As Double, _
green As Double, blue As Double
spread = max - min
Debug.Assert spread >= 0
ratio = (Value - min) / spread

If ratio < 0.25 Then
blue = 1
green = 4 * ratio
ElseIf ratio < 0.5 Then
green = 1
blue = 1 4 * (min - Value 0.25 * spread) / spread
ElseIf ratio < 0.75 Then
green = 1
red = 4 * (Value - min - 0.5 * spread) / spread
Else
red = 1
green = 1 4 * (min - Value 0.75 * spread) / spread

End If
heatMapColor = RGB(ramp(red * 255 * intensityRed, intensityRamp), _
ramp(green * 255 * intensityGreen, intensityRamp), _
ramp(blue * 255 * intensityBlue, intensityRamp))

End Function
Public Function ramp(v As Double, intensityRamp As Double) As Double
Dim x As Double, big As Double

If intensityRamp = 1 Then
ramp = v
Else
big = 1000

If intensityRamp < 0 Then
ramp = 1 - diminishingReturn(1 - v, Abs(intensityRamp) * big)
Else
ramp = diminishingReturn(v, intensityRamp * big)
End If
End If

End Function


Public Function rgbToHTMLHex(rgbColor As Long) As String
Dim r As Long, b As Long, g As Long
' extract components
r = rgbColor Mod &H100
g = (rgbColor \ &H100) Mod &H100
b = (rgbColor \ &H10000) Mod &H100
' just swap the colors round for rgb to bgr
rgbToHTMLHex = "#" & maskFormat(Hex(RGB(b, g, r)), "000000")

End Function
Private Function maskFormat(sIn As String, f As String) As String
Dim s As String
s = sIn
If Len(s) < Len(f) Then
s = Left(f, Len(f) - Len(s)) & s
End If
maskFormat = s
End Function

cJobject class

' this is used for object serliazation. Its just basic JSON with only string data types catered for
Option Explicit
'for more about this
' https://ramblings.mcpher.com/classes/datamanip/
'to contact me
' http://groups.google.com/group/excel-ramblings
'reuse of code
' https://ramblings.mcpher.com/reusing-code-from-this-site/
Private pParent As cJobject
Private pValue As Variant
Private pKey As String
Private pChildren As Collection
Private pValid As Boolean
Private pIndex As Long
Const cNull = "_null"
Const cRoot = "_deserialization"
Private pFake As Boolean ' not a real key
Private pisArrayRoot ' this is the root of an array
Private pPointer As Long ' this one is used for deserializing string
Private pJstring As String ' so is this
Private pWhatNext As String
Private pActive As Boolean
Private pJtype As eDeserializeType
Public Enum eDeserializeType
eDeserializeNormal
eDeserializeGoogleWire
End Enum
Public Property Get isValid() As Boolean
isValid = pValid
End Property
Public Property Get Fake() As Boolean
Fake = pFake
If Not pParent Is Nothing Then
Fake = Fake And pParent.isArrayRoot
End If
End Property
Public Property Get ChildIndex() As Long
ChildIndex = pIndex
End Property
Public Property Get isArrayRoot() As Boolean
isArrayRoot = pisArrayRoot
End Property
Public Property Get isArrayMember() As Boolean
If Not pParent Is Nothing Then
isArrayMember = pParent.isArrayRoot
Else
isArrayMember = False
End If
End Property
Public Property Let isArrayRoot(p As Boolean)
pisArrayRoot = p
End Property

Public Property Get Parent() As cJobject
Set Parent = pParent
End Property
Public Sub clearParent()
Set pParent = Nothing
End Sub
Public Property Get Root() As cJobject
Dim jo As cJobject
' the root is the object with no parent
Set jo = Me
While Not jo.Parent Is Nothing
Set jo = jo.Parent
Wend
Set Root = jo
End Property
Public Property Get key() As String
key = pKey
End Property
Public Property Get Value() As Variant
Value = pValue
End Property
Public Property Get toString() As String
toString = CStr(pValue)
End Property
Public Property Let Value(p As Variant)
pValue = p
End Property

Public Property Get Children() As Collection
Set Children = pChildren
End Property
Public Property Get hasChildren() As Boolean
hasChildren = False
If Not pChildren Is Nothing Then
hasChildren = (pChildren.Count > 0)
End If
End Property

Public Function init(p As cJobject, Optional k As String = cNull, Optional v As Variant = Empty) As cJobject
Set pParent = p
pisArrayRoot = False
pValid = True
pIndex = 1
pFake = (k = cNull)
If pFake Then
pKey = CStr(pIndex)
Else
pKey = k
End If


If Not pParent Is Nothing Then
If Not Child(pKey) Is Nothing Then
MsgBox ("Programming error " & pKey & " is a duplicate object")
pValid = False
Else
pIndex = pParent.Children.Count 1
If pFake Then
pKey = CStr(pIndex)
End If
pParent.Children.add Me, pKey
End If
End If

Set pChildren = New Collection
pValue = v

Set init = Me

End Function

Public Function Child(s As String) As cJobject
Dim astring As Variant, n As Long, jo As cJobject, jc As cJobject
If Len(s) > 0 Then
astring = Split(s, ".")
Set jo = Me
' we take something x.y.z and find the child
For n = LBound(astring) To UBound(astring)
Set jc = jo.ChildExists(CStr(astring(n)))
Set jo = jc
If jo Is Nothing Then Exit For
Next n
End If
Set Child = jo

End Function
Public Function Insert(Optional s As String = cNull, Optional v As Variant = Empty) As cJobject
Dim joNew As cJobject, sk As String
Set joNew = ChildExists(s)

If joNew Is Nothing Then
' if its an array, use the child index as the name if there is no name given
If pisArrayRoot And s = cNull Then
sk = cNull

Else
sk = s
End If

Set joNew = New cJobject
joNew.init Me, sk, v
Else
If Not IsEmpty(v) Then joNew.Value = v
End If
Set Insert = joNew
End Function
Public Function add(Optional k As String = cNull, Optional v As Variant = Empty) As cJobject
Dim astring As Variant, n As Long, jo As cJobject, jc As cJobject
astring = Split(k, ".")
Set jo = Me
' we take something x.y.z and add z with parent of y
For n = LBound(astring) To UBound(astring)
Set jc = jo.Insert(CStr(astring(n)), v)
Set jo = jc
Next n
Set add = jo
End Function
Public Function AddArray() As cJobject
pisArrayRoot = True
Set AddArray = Me
End Function
' check if this ChildExists in current children
Public Function ChildExists(s As String) As cJobject
On Error GoTo handle
Set ChildExists = pChildren(s)
Exit Function
handle:
Set ChildExists = Nothing
End Function
Public Function find(s As String) As cJobject
Dim jo As cJobject, f As cJobject
If key = s Then
Set f = Me
ElseIf hasChildren Then
For Each jo In pChildren
Set f = jo.find(s)
If Not f Is Nothing Then Exit For
Next jo
End If
Set find = f
End Function
Public Function fullKey() As String
' reconstruct full key to parent
Dim s As String, jo As cJobject
Set jo = Me
While Not jo Is Nothing
s = jo.key & "." & s
Set jo = jo.Parent
Wend
If Len(s) > 0 Then s = Left(s, Len(s) - 1)
fullKey = s

End Function

Public Function hasKey() As Boolean
hasKey = pKey <> vbNullString And _
pKey <> cNull And _
(hasChildren Or Not isArrayMember) And Not pFake
End Function
Public Function needsCurly() As Boolean
needsCurly = hasKey
If hasChildren Then
needsCurly = pChildren(1).hasKey
End If

End Function

Public Function needsSquare() As Boolean

needsSquare = isArrayRoot

End Function

Public Function Serialize(Optional blf As Boolean = False) As String
' make a JSON string of this structure
Serialize = " {" & vbLf & recurseSerialize(Me, , blf) & vbLf & " }"
End Function
Private Function escapeify(s As String) As String
escapeify = Replace(Replace(Replace(Replace(s, q, "\" & q), qs, "\" & qs), ">", "\>"), "<", "\<")

End Function
Public Property Get needsIndent() As Boolean
needsIndent = needsCurly Or needsSquare
End Property
Public Function recurseSerialize(job As cJobject, Optional soFar As String = "", _
Optional blf As Boolean = False) As String
Dim s As String, jo As cJobject
Static indent As Long
If indent = 0 Then indent = 3

s = soFar
If blf And (job.hasKey Or job.needsCurly) Then s = s & Space(indent)

If job.hasKey Then
s = s & quote(job.key) & ":"
End If

If Not job.hasChildren Then
If blf And Not job.hasKey Then s = s & Space(indent)
s = s & quote(CStr(escapeify(job.Value)))
Else
' arrays need squares

If job.needsSquare Then s = s & "["
If job.needsCurly Then s = s & "{"
If blf And Not job.isArrayRoot Then s = s & vbLf
If job.needsIndent Then
indent = indent 3
End If

For Each jo In job.Children
s = recurseSerialize(jo, s, blf) & ","
If blf Then s = s & vbLf
Next jo

' get rid of trailing comma
If blf Then
s = Left(s, Len(s) - 2)
Else
s = Left(s, Len(s) - 1)
End If

If job.needsIndent Then
indent = indent - 3
If blf Then s = s & vbLf
End If
If blf Then s = s & Space(indent)
If job.needsCurly Then s = s & "}"
If job.needsSquare Then s = s & " ]"

End If
recurseSerialize = s
End Function

Public Property Get longestFullKey() As Long
longestFullKey = clongestFullKey(Root)
End Property

Public Property Get Depth(Optional L As Long = 0) As Long
Dim jo As cJobject
L = L 1
For Each jo In pChildren
L = jo.Depth(L)
Next jo
Depth = L
End Property
Private Function clongestFullKey(job As cJobject, Optional soFar As Long = 0) As Long
Dim jo As cJobject
Dim L As Long
L = Len(job.fullKey)
If L < soFar Then L = soFar
If Not job.Children Is Nothing Then
For Each jo In job.Children
L = clongestFullKey(jo, L)
Next jo
End If
clongestFullKey = L
End Function
Public Property Get formatData(Optional bDebug As Boolean = False) As String
formatData = cformatdata(Root, , bDebug)
End Property
Private Function cformatdata(job As cJobject, Optional soFar As String = "", Optional bDebug As Boolean = False) As String
Dim jo As cJobject, ji As cJobject
Dim s As String
s = soFar

s = s & itemFormat(job, bDebug)
If job.hasChildren Then
For Each ji In job.Children
s = cformatdata(ji, s, bDebug)
Next ji
End If


cformatdata = s
End Function
Private Function itemFormat(jo As cJobject, Optional bDebug As Boolean = False) As String
Dim s As String
s = jo.fullKey & Space(longestFullKey 4 - Len(jo.fullKey)) _
& CStr(jo.Value)
If bDebug Then
s = s "("
s = s & "debug: Haskey :" & jo.hasKey & " NeedsCurly :" & jo.needsCurly & " NeedsSquare:" & jo.needsSquare
s = s " isArrayMember:" & jo.isArrayMember & " isArrayRoot:" & jo.isArrayRoot & " Fake:" & jo.Fake
s = s & ")"

End If
itemFormat = s vbCrLf
End Function
Public Sub jdebug()
Debug.Print formatData(True)
End Sub
Private Function quote(s As String) As String
quote = q & s & q
End Function
Public Function deSerialize(s As String, Optional jtype As eDeserializeType = eDeserializeNormal) As cJobject
' this will take a simple JSON string and deserialize into a cJobject branch starting at ME
' prepare string for processing
Dim jo As cJobject

pPointer = 1
pJstring = noisyTrim(s)
Set jo = New cJobject
jo.init Nothing, cRoot
pJtype = jtype
Set jo = dsLoop(jo)
' already has its own root
If jtype = eDeserializeGoogleWire Then
Set jo = jo.Children(1)
jo.clearParent
End If

Set deSerialize = jo
End Function
Private Function noisyTrim(s As String) As String
Dim ns As String
ns = Trim(s)
If Len(ns) > 0 Then
While (isNoisy(Right(ns, 1)))
ns = Left(ns, Len(ns) - 1)
Wend
End If
noisyTrim = ns
End Function
Private Function nullItem(job As cJobject) As cJobject
Set nullItem = Nothing

If peek() = "," Then
' need an array element
' simulate a { 'x':'x}
If pJtype = eDeserializeGoogleWire Then
Set nullItem = job.add.add("v")
Else
Set nullItem = job.add
End If
End If


End Function

Private Function dsLoop(job As cJobject) As cJobject
Dim cj As cJobject, jo As cJobject, ws As String
Set jo = job
pActive = True
pWhatNext = "{["
While pPointer <= Len(pJstring) And pActive
Set jo = dsProcess(jo)
Wend
Set dsLoop = job
End Function
Private Function okWhat(what As String) As Boolean

okWhat = (InStr(pWhatNext, nOk) <> 0 And _
(what = "." Or what = "-" Or IsNumeric(what))) Or _
(InStr(pWhatNext, what) <> 0)


End Function
Private Function dsProcess(job As cJobject) As cJobject
Dim k As Long, jo As cJobject, s As String, what As String, jd As cJobject, v As Variant

'are we done?
Set dsProcess = job
If pPointer > Len(pJstring) Then Exit Function

Set jo = job
ignoreNoise
' is it what was expected
what = pointedAt
If Not okWhat(what) Then
badJSON pWhatNext
Exit Function
End If
' process next token
Select Case what
' start of key:value pair- do nothing except set up to get the key name
Case "{"
pPointer = pPointer 1
If jo.isArrayRoot Then Set jo = jo.add
Set dsProcess = jo
pWhatNext = anyQ & ","

' its the beginning of an array - need to kick off a new array
Case "["
pPointer = pPointer 1
If nullItem(jo.AddArray) Is Nothing Then
pWhatNext = nOk & anyQ & "{],"
Else
pWhatNext = ","
End If
Set dsProcess = jo


' could be a key or an array value
Case q, qs, "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "-", "."
v = getvItem
If IsEmpty(v) Then
badJSON pWhatNext
Else
' start of key/value pair
If peek() = ":" Then
' add as a new key, and set up for getting the value
Set jo = jo.add(CStr(v))
pWhatNext = ":"
ElseIf jo.isArrayRoot Then
' an array value is allowed without a key
jo.add , v
pWhatNext = ",]"
Else
badJSON pWhatNext
End If
Set dsProcess = jo

End If

' its the value of a pair
Case ":"
pPointer = pPointer 1
v = getvItem
If IsEmpty(v) Then
' about to start an array rather than get a value
pWhatNext = "{["
Else
' store the value, come back for the next
jo.Value = v
Set jo = jo.Parent
pWhatNext = ",}"
End If
Set dsProcess = jo

Case ","
' another value - same set
pPointer = pPointer 1
If nullItem(jo) Is Nothing Then
pWhatNext = nOk & anyQ & "{}],"
Else
pWhatNext = ","
End If
Set dsProcess = jo

Case "}"
' backup a level
pPointer = pPointer 1
pWhatNext = ",]}"
Set dsProcess = jo.Parent

Case "]"
' backup a level
pPointer = pPointer 1
pWhatNext = ",}"
Set dsProcess = jo.Parent

Case Else
' unexpected thing happened
badJSON pWhatNext

End Select


End Function
Private Function nOk() As String
' some character to say that a numeric is ok
nOk = Chr(254)
End Function
Private Function getvItem(Optional whichQ As String = "") As Variant
Dim s As String
' is it a string?
getvItem = Empty
ignoreNoise
If isQuote(pointedAt) Then
getvItem = getQuotedItem(whichQ)

Else
' maybe its a number
s = getNumericItem
If Len(s) > 0 Then getvItem = toNumber(s)

End If
End Function
Private Function peek() As String
Dim k As Long
' peek ahead to next non noisy character
k = pPointer
ignoreNoise
peek = pointedAt
pPointer = k
End Function
Private Function peekBehind() As String
Dim k As Long
k = pPointer - 1
While k > 0 And isNoisy(pointedAt(k))
k = k - 1
Wend
If k > 0 Then
peekBehind = pointedAt(k)
End If
End Function
Private Function toNumber(sIn As String) As Variant
' convert string to numeric , either double or long
Dim ts As String, s As String
' find out the '.' separator for this locale
ts = Mid(CStr(1.1), 2, 1)
' and use it so that cdbl works properly
s = Replace(sIn, ".", ts)
On Error GoTo overflow


If InStr(1, s, ts) Then
toNumber = CDbl(s)
Else
toNumber = CLng(s)
End If
Exit Function

overflow:
' just deal with it silently
toNumber = 0
Resume Next


End Function
Private Function pointedAt(Optional pos As Long = 0, Optional sLen As Long = 1) As String
' return what ever the currently quoted character is
Dim k As Long
If pos = 0 Then
k = pPointer
Else
k = pos
End If
pointedAt = Mid(pJstring, k, sLen)
End Function

Private Function getQuotedItem(Optional whichQ As String = "") As String
Dim s As String, k As Long, wq As String
ignoreNoise
s = ""

If isQuote(pointedAt, whichQ) Then
wq = pointedAt
' extract until the next matching quote
k = pPointer 1

While Not isQuote(pointedAt(k), wq)
If isUnicode(pointedAt(k, 2)) Then
s = s & ChrW(CLng("&H" & pointedAt(k 2, 4)))
'S = S & StrConv(Hex2Dec(pointedAt(k 2, 4)), vbFromUnicode)
k = k 6

ElseIf isEscape(pointedAt(k)) Then
s = s & pointedAt(k 1)
k = k 2
Else
s = s & pointedAt(k)
k = k 1
End If
Wend
pPointer = k 1
End If
getQuotedItem = s

End Function
Private Function getNumericItem() As String
Dim s As String, k As Long
ignoreNoise
s = pseudoNumeric

If Len(s) = 0 Then
k = pPointer
While IsNumeric(pointedAt(k)) Or pointedAt(k) = "." Or pointedAt(k) = "-"
s = s & pointedAt(k)
k = k 1
Wend
pPointer = pPointer Len(s)

End If
getNumericItem = s

End Function
Private Function pseudoNumeric() As String
Dim ps As String, s As String
s = pointedAt(, 4)
If pointedAt(, 5) = "false" Then s = pointedAt(, 5)
Select Case s
Case "null", "false"
ps = "0"
Case "true"
ps = "1"
Case Else
pseudoNumeric = vbNullString
Exit Function
End Select

pseudoNumeric = ps
pPointer = pPointer Len(s)
End Function

Private Function isQuote(s As String, Optional whichQ As String = "") As Boolean
If Len(whichQ) = 0 Then
' any quote
isQuote = (s = q Or s = qs)
Else
isQuote = (s = whichQ)
End If
End Function
Private Sub badJSON(pWhatNext As String, Optional add As String = "")
MsgBox add & "got " & pointedAt & " expected --(" & pWhatNext & _
")-- Bad JSON at character " & CStr(pPointer) & " starting at " & _
Mid(pJstring, pPointer)
pValid = False
pActive = False

End Sub

Private Sub ignoreNoise(Optional pos As Long = 0, Optional extraNoise As String = "")
Dim k As Long, t As Long
If pos = 0 Then
t = pPointer
Else
t = pos
End If
For k = t To Len(pJstring)
If Not isNoisy(Mid(pJstring, k, 1), extraNoise) Then Exit For
Next k
pPointer = k
End Sub
Private Function isNoisy(s As String, Optional extraNoise As String = "") As Boolean
isNoisy = InStr(vbTab & " " & vbCrLf & vbCr & vbLf & extraNoise, s)
End Function
Private Function isEscape(s As String) As Boolean
isEscape = (s = "\")
End Function
Private Function isUnicode(s As String) As Boolean
isUnicode = LCase(s) = "\u"
End Function
Private Function q() As String
q = Chr(34)
End Function
Private Function qs() As String
qs = Chr(39)
End Function
Private Function anyQ() As String
anyQ = q & qs
End Function

cRegXlib class

Option Explicit
'for more about this
' https://ramblings.mcpher.com/classes/datamanip/
'to contact me
'https://gitter.im/desktopliberation/community
'reuse of code
' https://ramblings.mcpher.com/reusing-code-from-this-site/
' for building up a library of useful regex expressions
Private pName As String
Private pRegex As RegExp
Public Property Get Pattern() As String
Pattern = pRegex.Pattern
End Property
Public Property Let Pattern(p As String)
pRegex.Pattern = p
End Property
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(p As String)
pName = p
End Property
Public Property Get ignorecase() As Boolean
ignorecase = pRegex.ignorecase
End Property
Public Property Let ignorecase(p As Boolean)
pRegex.ignorecase = p
End Property
Public Property Get rGlobal() As Boolean
rGlobal = pRegex.Global
End Property
Public Property Let rGlobal(p As Boolean)
pRegex.Global = p
End Property

Public Sub init(sName As String, _
Optional spat As String = "", _
Optional bIgnoreSpaces As Boolean = True, _
Optional bIgnoreCase As Boolean = True, _
Optional bGlobal As Boolean = True)

Dim s As String
s = spat
If bIgnoreSpaces Then
s = Replace(s, " ", "")
End If
Set pRegex = New RegExp
With pRegex
.Pattern = s
.ignorecase = bIgnoreCase
.Global = bGlobal
End With
pName = sName

End Sub
Public Function getString(sFrom As String) As String
Dim mc As matchcollection, am As Match, rs As String
Set mc = pRegex.execute(sFrom)
rs = ""
For Each am In mc
rs = rs & am.Value
Next am
getString = rs
End Function
Function getReplace(sFrom As String, sTo As String) As String
getReplace = pRegex.Replace(sFrom, sTo)

End Function
Function getTest(sFrom As String) As Boolean
getTest = pRegex.Test(sFrom)

End Function

ctagCloud class

Option Explicit
Private pJob As cJobject
Private pDumpNoise As Boolean
Private pMinCountToShow As Long
Private pSep As String
Private pNoise As Collection
Private pNoiseString As String
Private pColorful As Boolean
Private pBiggest As Double
Private pSmallest As Double

Public Property Get tagJob() As cJobject
Set tagJob = pJob
End Property

Public Function init(Optional sName As String = "tagcloud", _
Optional bDump As Boolean = True, _
Optional lMinCountToShow As Long = 1, _
Optional sep As String = ",", _
Optional sNoiseString As String = vbNullString, _
Optional bColorful As Boolean = True, _
Optional dSmallest As Double = 8, _
Optional dBiggest As Double = 40) As cTagCloud
Dim a As Variant, i As Long, k As String
pBiggest = dBiggest
pSmallest = dSmallest
Set pJob = New cJobject
With pJob
.init Nothing, sName
End With
pColorful = bColorful
pDumpNoise = bDump
pMinCountToShow = lMinCountToShow
pSep = sep
If pDumpNoise Then
If sNoiseString = vbNullString Then
pNoiseString = _
"and" & "," & "the" & "," & "a" & "," & "of" & "," & _
"be" & "," & "is" & "," & "for" & "," & "on" & "," & _
"to" & "," & "in" & "," & "i" & "," & "where" & "," & _
"when" & "," & "this" & "," & "that" & "," & "can" & _
"," & "how" & "," & "with" & "," & "so" & "," & "it" & _
"," & "got" & "," & "get" & "," & _
"so" & "," & "my" & "," & "me" & "," & "if" & "," & "had" _
& "," & "no" & "," & "or" & "," & "im" & "," & "do" & "," _
& "did" & "," & "has" & "," & "have" & "," & _
"will" & "," & "her" & "," & "him" & "," & "his" & "," _
& "its" & "," & "now" & "," & "then" & "," & "by" & "," & "at" _
& "," & "an" & "," & "not" & "," & _
"but" & "," & "are" & "," & "us" & "," & "on" & "," & _
"a" & "," & "so" & "," & "was" & "," & "an" & "," & "we" & "," & _
"you" & "," & "as" & "," & "he" & "," & "what" & "," & "hyperlink" & _
"," & "would" & "," & "these" & "," & "their" & "," & "amto" & "," & "subject" & _
"," & "re" & "," & "sent" & "," & "from" & "," & "who" & "," & "it" & "," & _
"," & "its" & "," & "im" & "," & "dont" & "," & "amto" & "," & "i" & _
"," & "id" & "," & "ill" & "," & "im"
Else
pNoiseString = sNoiseString
End If
Set pNoise = New Collection
a = Split(pNoiseString, ",")
For i = LBound(a) To UBound(a)
k = LCase(Trim(CStr(a(i))))
If Not isNoise(k) Then pNoise.add k, k
Next i
End If
Set init = Me
End Function
Public Function increment(sTerm As String, Optional amount As Long = 1) As cJobject
Dim jo As cJobject
With tagJob
Set jo = .ChildExists(sTerm)
If jo Is Nothing Then
Set jo = .add(sTerm)
With jo
.add "count", 0
.add "scale", 0.1
.add "size", 0.1
.add "show", False
.add "color", vbBlack
End With
End If
With jo.Child("count")
.Value = .Value 1
End With
End With
Set increment = jo
End Function
Public Function collect(sIn As String) As cTagCloud
Dim a As Variant, i As Long, s As String
a = Split(Trim(Replace(sIn, "'", vbNullString)), pSep)
For i = LBound(a) To UBound(a)
s = cleanNoise(CStr(a(i)))
If s <> vbNullString Then increment CStr(s)
Next i
Set collect = Me
End Function
Private Function cleanNoise(sIn As String) As String
Dim s As String
s = LCase(Trim(sIn))
If pDumpNoise Then

s = rxReplace("nonprintable", s, " ")
s = rxReplace("punctuation", s, " ")
s = rxReplace("singlespace", s, "$1")
s = Trim(s)
If isNoise(s) Then s = vbNullString
End If
cleanNoise = s
End Function
Public Function getSize() As cTagCloud
Dim jo As cJobject, vSmall As Variant, vBig As Variant, v As Variant

' find biggest and smallest
For Each jo In pJob.Children
With jo
v = .Child("count").Value
If v >= pMinCountToShow Then
.Child("show").Value = True
If v < vSmall Or IsEmpty(vSmall) Then vSmall = v
If v > vBig Or IsEmpty(vBig) Then vBig = v
End If
End With
Next jo
' calculate size scale
For Each jo In pJob.Children
With jo
If .Child("count").Value >= pMinCountToShow Then
If vBig > vSmall Then
.Child("scale").Value = (.Child("count").Value - vSmall) / (vBig - vSmall)
Else
.Child("scale").Value = 1
End If
.Child("size").Value = .Child("scale").Value * (pBiggest - pSmallest) pSmallest
If pColorful Then
.Child("color").Value = heatMapColor(vSmall, vBig, .Child("count").Value)
End If
End If
End With
Next jo

Set getSize = Me
End Function
Public Function htmlResults() As String
Dim k As Long, jo As cJobject, s As String

getSize

s = vbNullString

For Each jo In tagJob.Children
If jo.Child("show").Value Then
If s <> vbNullString Then s = s & pSep
s = s & "<span style='font-size:" & _
jo.Child("size").toString & "px;color:" & _
rgbToHTMLHex(CLng(jo.Child("color").Value)) & _
";'>" & jo.key & "</span>"
End If
Next jo
htmlResults = s
End Function
Private Function isNoise(sid As String) As Boolean
Dim s As String
On Error GoTo handle
s = pNoise(sid)
isNoise = True
Exit Function
handle:
isNoise = False
End Function

Summary

For more tips like this, take a look at Get Started Snippets  In the meantime why not join our forum, follow the blog or follow me on Twitter to ensure you get updates when they are available. You can also submit anything you want considered for publication on this site to our forum.   See How to use cJobject , Data Manipulation Classes and Rest to Excel library for more information on some of the capabilities mentioned on this page, or see how to How to create a tag cloud in Excel.