Binaryworld - GetWordOccurrences - Number of occurrences of each word in a string ... [ VB -> Regular Expression ]

' Analyze a source string and return a bidimensional array that contains
' all the words the string contains and the number of occurrences of each
'
' Example of usage:
'   Dim arr() as Variant
'   arr = GetWordsOccurrences(txtSource.Text)
'   For i = 1 To UBound(arr, 2)
'     Print "Word " & arr(0, i) & ": " & arr(1, i) & " occurrences"
'   Next
'
' NOTE: requires a reference to the
'    Microsoft VBScript Regular Expression type library

Function GetWordsOccurrences(ByVal Text As String) As Variant()
  Dim re As New RegExp
  Dim ma As Match
  Dim col As New Collection
  Dim ndx As Long

  ' the following pattern means that we're looking for a word character (\w)
  ' repeated one or more times (the + suffix), and that occurs on a word
  ' boundary (leading and trailing \b sequences)
  re.Pattern = "\b\w+\b"
  ' search for *all* occurrences
  re.Global = True

  ' let's start with an array of 100 elements
  ReDim res(1, 100) As Variant

  ' we need this to work with the collection
  On Error Resume Next

  For Each ma In re.Execute(Text)
    ' the index in the array where this word should be inserted,
    ' if not already in the array
    ndx = col.Count + 1
    ' attempt to add this to the collection
    col.Add ndx, ma.Value
    ' if no error, this is the first occurrence of the word and the
    ' element in the collection already contains the index of the
    ' corresponding element in the array
    If Err = 0 Then
      ' ensure the array is large enough
      If ndx > UBound(res, 2) Then
        ' if not, add 100 elements
        ReDim Preserve res(1, ndx + 99) As Variant
      End If
      ' insert the word and initialize word count
      res(0, ndx) = ma.Value
      res(1, ndx) = 1

    Else
      ' the word is already in the array
      Err.Clear
      ' get the index in the array
      ndx = col(ma.Value)
      ' increment word count
      res(1, ndx) = res(1, ndx) + 1
    End If
  Next

  ' trim the result array
  If col.Count Then
    ReDim Preserve res(1, col.Count) As Variant
    GetWordsOccurrences = res
  End If

End Function