A tagCloud in Outlook

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 http://office.microsoft.com/en-us/outlook-help/add-a-button-menu-or-command-HP005192201.aspx.  

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
' http://ramblings.mcpher.com/Home/excelquirks/classeslink/data-manipulation-classes
'to contact me
' http://groups.google.com/group/excel-ramblings
'reuse of code
' http://ramblings.mcpher.com/Home/excelquirks/codeuse
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 = "%20"

  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
' http://ramblings.mcpher.com/Home/excelquirks/classeslink/data-manipulation-classes
'to contact me
' http://groups.google.com/group/excel-ramblings
'reuse of code
' http://ramblings.mcpher.com/Home/excelquirks/codeuse
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
' http://ramblings.mcpher.com/Home/excelquirks/classeslink/data-manipulation-classes
'to contact me
' http://groups.google.com/group/excel-ramblings
'reuse of code
' http://ramblings.mcpher.com/Home/excelquirks/codeuse
' 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

Comments