Word Add-IN to Persist a Dictionary Object as XML

A friend of my eldest child asked for some advice on creating a database. Seems that she was a keen fiction writer and needed to keep track of the meanings of the words she’d invented.

A Database would be overkill for the job and it seemed like a good opportunity to practice using XML and VBA.  Two scripting.dictionary objects could be used to hold the data in memory while creating the story. One for fiction to english translation and the other to perform reverse lookups. The data would be retrieved from the xml file when the add-in loaded and saved when it was unloaded.

It turned out to be a pretty simple job and the code is shown below. Four simple functions were required: add a word, delete a word, lookup and reverse lookup.

Dictionary Code Module

Option Explicit
Public objDict, objRDict As Variant
Public Const MYDOCUMENTS As Integer = 16
Public Const XML_ATTR_KEY As String = "Word"
Public Const XML_ATTR_VALUE As String = "Meaning"
Public Const XML_ELEMENT_OUTER As String = "Dictionary"
Public Const XML_ELEMENT_INNER As String = "Entry"
Public Const STR_INDENT As String = vbCrLf & "    "
Public Const XPATH As String = "/Dictionary/Entry"
Public Const STR_DICT_FILENAME As String = "EDictionary.xml"

Sub initDict()

Set objDict = CreateObject("Scripting.Dictionary")
Set objRDict = CreateObject("Scripting.Dictionary")

End Sub

Function GetMyDocuments() As String
Dim WSHShell As Object
  Set WSHShell = CreateObject("Wscript.Shell")
  GetMyDocuments = WSHShell.SpecialFolders(MYDOCUMENTS)
  Set WSHShell = Nothing
End Function

Sub addword()
Dim strFWord, strEWord As String
Dim frmTemp As Variant
Dim dlgResult As Integer

  If (Not Selection Is Nothing) Then
    strFWord = Trim(Selection.Words(1).Text)
  End If
  Set frmTemp = New frmLookup
  frmTemp.mkAddEntry (strFWord)
  Do
    frmTemp.Show
    If frmTemp.dlgResult = vbCancel Then
      Unload frmTemp
      Set frmTemp = Nothing
      Exit Sub
    End If
    strFWord = frmTemp.Fictionword()
    strEWord = frmTemp.Englishword()
    If (strFWord <> "" And _
        strEWord <> "" And _
        Not objDict.Exists(strFWord)) Then
      objDict.Add strFWord, strEWord
      objRDict.Add strEWord, strFWord
      Exit Do
    Else
      MsgBox "Word already exists in Dictionary or is blank.", vbExclamation
    End If
  Loop
End Sub

Sub delword()
Dim strFWord, strEWord As String
Dim frmTemp As Variant
Dim dlgResult As Integer

  If (Not Selection Is Nothing) Then
    strFWord = Trim(Selection.Words(1).Text)
  End If
  Set frmTemp = New frmLookup
  frmTemp.mkDelEntry (strFWord)
  Do
    frmTemp.Show
    If frmTemp.dlgResult = vbCancel Then
      Unload frmTemp
      Set frmTemp = Nothing
      Exit Sub
    End If
    strFWord = frmTemp.Fictionword()
    strEWord = frmTemp.Englishword()
    If (strFWord <> "" And objDict.Exists(strFWord)) Then
      strEWord = objDict.Item(strFWord)
      objDict.Remove strFWord
      If objRDict.Exists(strEWord) Then
        objRDict.Remove strEWord
      End If
      Exit Do
    Else
      MsgBox "Word not found in Dictionary.", vbExclamation
    End If
  Loop
End Sub

Sub rlookup()
Dim strFWord, strEWord, strMsg As String
Dim frmTemp As Variant
Dim dlgResult As Integer

  If (Not Selection Is Nothing) Then
    strEWord = Trim(Selection.Words(1).Text)
  End If
  Set frmTemp = New frmLookup
  frmTemp.mkRLookup (strEWord)
  Do
    frmTemp.Show
    If frmTemp.dlgResult = vbCancel Then
      Unload frmTemp
      Set frmTemp = Nothing
      Exit Sub
    End If
    strEWord = frmTemp.Englishword()
    If (strEWord <> "" And objRDict.Exists(strEWord)) Then
      strFWord = objRDict.Item(strEWord)
      frmTemp.FictionText = strFWord
    Else
      MsgBox "Word not found in Dictionary.", vbExclamation
    End If
  Loop
End Sub

Sub lookup()
Dim strFWord, strEWord, strMsg As String
Dim frmTemp As Variant
Dim dlgResult As Integer

  If (Not Selection Is Nothing) Then
    strFWord = Trim(Selection.Words(1).Text)
  End If
  Set frmTemp = New frmLookup
  frmTemp.mkLookup (strFWord)
  Do
    frmTemp.Show
    If frmTemp.dlgResult = vbCancel Then
      Unload frmTemp
      Set frmTemp = Nothing
      Exit Sub
    End If
    strFWord = frmTemp.Fictionword()
    If (strFWord <> "" And objDict.Exists(strFWord)) Then
      strEWord = objDict.Item(strFWord)
      frmTemp.EnglishText = strEWord
    Else
      MsgBox "Word not found in Dictionary.", vbExclamation
    End If
  Loop
End Sub

Sub dsave()
Dim strFileName As String

  strFileName = GetMyDocuments() & "\" & STR_DICT_FILENAME
  savedictionary (strFileName)
End Sub

Sub dload()
Dim strFileName As String

  strFileName = GetMyDocuments() & "\" & STR_DICT_FILENAME
  loaddictionary (strFileName)
End Sub

Sub savedictionary(strFileName)
Dim xmlDoc As DOMDocument
Dim key As Variant
Dim dict, entry, word, meaning, node As IXMLDOMNode

  Set xmlDoc = New DOMDocument
  Set node = xmlDoc.createNode(NODE_ELEMENT, XML_ELEMENT_OUTER, "")
  Set dict = xmlDoc.appendChild(node)
  For Each key In objDict.keys()
    Set node = xmlDoc.createTextNode(STR_INDENT)
    dict.appendChild node
    Set node = xmlDoc.createNode(NODE_ELEMENT, XML_ELEMENT_INNER, "")
    Set entry = dict.appendChild(node)
    Set word = xmlDoc.createAttribute(XML_ATTR_KEY)
    word.Text = key
    entry.Attributes.setNamedItem word
    Set meaning = xmlDoc.createAttribute(XML_ATTR_VALUE)
    meaning.Text = objDict.Item(key)
    entry.Attributes.setNamedItem meaning
  Next key
  Set node = xmlDoc.createTextNode(vbCrLf)
  dict.appendChild node
  xmlDoc.Save strFileName
End Sub

Sub loaddictionary(strFileName)
Dim xmlDoc As DOMDocument
Dim entries As IXMLDOMNodeList
Dim entry, word, meaning As IXMLDOMNode
Dim strWord, strMeaning As String

  initDict
  Set xmlDoc = New DOMDocument ' Create xmldoc and load the specified xml file
  xmlDoc.Load (strFileName)
  If xmlDoc.documentElement Is Nothing Then
    MsgBox "Error loading xml dictionary file: " _
      & vbCrLf & strFileName & vbCrLf _
      & "File not found or failed to parse." _
      , vbCritical
    Exit Sub
  End If
' Select all dictionary entries from the xml file
  Set entries = xmlDoc.selectNodes(XPATH)
' For each entry check for and extract the attributes
  For Each entry In entries
    Set word = entry.Attributes.getNamedItem(XML_ATTR_KEY)
    Set meaning = entry.Attributes.getNamedItem(XML_ATTR_VALUE)
    If (Not (word Is Nothing) And Not (meaning Is Nothing)) Then
      strWord = word.Text
      strMeaning = meaning.Text
      If (Not objDict.Exists(strWord)) Then
        objDict.Add strWord, strMeaning         'add to dictionary
        If (Not objRDict.Exists(strMeaning)) Then
          objRDict.Add strMeaning, strWord    'add to rev. dictionary
        End If
      End If
    End If
  Next entry
End Sub

Autoexec Module

Option Explicit
Sub main()
Dim cmdEbar As CommandBar
Dim ctlPopup As CommandBarPopup
Dim ctlButton As CommandBarButton
Dim i As Integer

  initDict ' initialise the in memory dictionary structures
  dload    ' load previously persisted dictionary xml file

  Set cmdEbar = Application.CommandBars.Add("E's Toolbar", , , True)
  With cmdEbar
    .Visible = True
    .Position = msoBarTop
  End With
  For i = 1 To 4
    Set ctlButton = cmdEbar.Controls.Add(Type:=msoControlButton)
    With ctlButton
      .Visible = True
      .Style = msoButtonIcon
      Select Case i
        Case 1
          .FaceId = 2006
          .OnAction = "addword"
          .TooltipText = "Add word to dictionary"
        Case 2
          .OnAction = "delword"
          .TooltipText = "Delete word from dictionary"
          .FaceId = 2005
        Case 3
          .OnAction = "lookup"
          .TooltipText = "Lookup Fiction -> English"
          .FaceId = 229
        Case 4
          .OnAction = "rlookup"
          .TooltipText = "Lookup English -> Fiction"
          .FaceId = 1820
        Case Else
      End Select
    End With
  Next i
End Sub

Sub main()
  Application.CommandBars("E's Toolbar").Delete ' lose the toolbar
  Call dsave  ' persist the dictionary to an XML file
End Sub

Form Code Module

Option Explicit
Private intResult As Integer  

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  If CloseMode = vbFormControlMenu Then
    Cancel = True           ' cancel this close event to prevent automation errors
    cmdCancel_Click     ' and start our approved shutdown sequence
  End If
End Sub

Property Get dlgResult() As Integer
  dlgResult = intResult
End Property

Private Sub cmdCancel_Click()
  intResult = vbCancel
  Me.Hide
End Sub

Private Sub cmdOk_Click()
  intResult = vbOK
  Me.Hide
End Sub

Public Sub mkLookup(strWord As String)
  txtEnglish.Enabled = False txtEnglish.BackColor = &H80000011
  txtFiction.Text = strWord
End Sub

Public Sub mkRLookup(strWord As String)
  txtFiction.Enabled = False
  txtFiction.BackColor = &H80000011
  Me.Caption = "Reverse " & Me.Caption
  txtEnglish.Text = strWord
End Sub

Public Sub mkAddEntry(strWord As String)
  Me.Caption = "Add Dictionary Entry"
  txtFiction.Text = strWord
End Sub

Public Sub mkDelEntry(strWord As String)
  Me.Caption = "Remove Dictionary Entry"
  txtEnglish.Enabled = False
  txtEnglish.BackColor = &H80000011
  txtFiction.Text = strWord
End Sub

Property Get Englishword() As String
Dim Englishwords As Variant
  Englishwords = Split(Trim(txtEnglish.Text)) ' remove leading spaces and get words
  If (UBound(Englishwords) <> -1) Then
    Englishword = LCase(Englishwords(0))
  Else
    Englishword = ""
  End If
End Property

Property Get Fictionword() As String
Dim Fictionwords As Variant
  Fictionwords = Split(Trim(txtFiction.Text)) ' remove leading spaces and get words
  Fictionword = Fictionwords(0)
  If (UBound(Fictionwords) <> -1) Then
    Fictionword = LCase(Fictionwords(0))
  Else
    Fictionword = ""
  End If
End Property

Property Let EnglishText(strWord)
  txtEnglish.Text = strWord
End Property

Property Let FictionText(strWord)
  txtFiction.Text = strWord
End Property

The Form