MS Word 2003 VBA - Use only custom dictionary for replacing format in (non-)spelling errors

Question

I'd like to replace the format of words matching words in another txt-file. I tried several things but finally came to a solution of which I think is the most effective.

Here's the code which is not working satisfactorily, because the main dictionary is not disabled...

Sub format_dict_words()

Dim rngWord As Range

DoEvents

For Each rngWord In ActiveDocument.Range.Words
DoEvents
 If Application.CheckSpelling( _
   Word:=rngWord.Text, _
   customdictionary:="I:\NATUR\Kay\DIC\test.DIC", _
   MainDictionary:="I:\NATUR\Kay\DIC\test.DIC", _
   IgnoreUppercase:=False) = True Then
   rngWord.Bold = True
End If
Next rngWord

End Sub

I'd need to disable the main dictionary, then the non-spelling errors would really be only the matches with my test.DIC. And, as the spelling-checker seems to exclude everything that's not word-characters, these signs are treated as non-errors and bolded, too. Maybe I'd need to insert a regex to treat this issue..

Answer 1

You were close with your first solution. The trick is that you have to store your custom dictionary somewhere OUTSIDE of Word's default "UProof" directory, or else Word lumps all dictionaries together for the spell check. Similar to your second solution, you'll have to manually add words to the custom dictionary, eg using Notepad.

So copy the custom dictionary to another location, for example to "My Documents". Custom dictionaries in Office 2010 are located in C:\\Users\\USERNAME\\AppData\\Roaming\\Microsoft\\UProof . Next, remove the custom dictionary from Word's dictionaries list. In Office 2010, this list is located in File > Options > Proofing > Custom Dictionaries. Select the custom dictionary from the list and click "Remove".

Now here's the revised VBA code that should apply formatting (in this case a custom style called CustomDict) only to words in the relocated custom dictionary:

Option Explicit

Sub CustomDictStyle()

    Dim rngWord As Range

    DoEvents

    For Each rngWord In ActiveDocument.Range.Words

        DoEvents

        'Include words in custom dictionary

        If Application.CheckSpelling( _
        Word:=rngWord.Text, _
        CustomDictionary:="C:\Users\USERNAME\Documents\CUSTOM.dic", _
        IgnoreUppercase:=False) = True Then

            'Now exclude words in the main dictionary

            If Application.CheckSpelling( _
                Word:=rngWord.Text, _
                IgnoreUppercase:=False) = False Then

                    'Apply style as desired
                    rngWord.Style = "CustomDict"

            End If

        End If

    Next rngWord

End Sub

This stupid forum won't let me upload an image, but here's a link to what it should look like . Note that the red "CustomDict" style was applied to the word "fleurghy" which I added to my custom dictionary.

Answer 2

@Jeremy, I tried to apply your code, but somehow not all words in mydict.txt are newly formatted..

Option Explicit

Sub CustomDictStyle()

    Dim StartTime As Double, EndTime As Double
    Dim rngWord As Range

    'Stores start time in variable "StartTime"
    StartTime = Timer

    'remove custom dictionaries
    CustomDictionaries.ClearAll

    DoEvents

    For Each rngWord In ActiveDocument.Range.Words

        DoEvents

        'Include words in custom dictionary

        If Application.CheckSpelling( _
        Word:=rngWord.Text, _
        CustomDictionary:="C:\Dokumente und Einstellungen\kcichini\Eigene Dateien\Stuff\mydict.txt", _
        IgnoreUppercase:=False) = True Then

            'Now exclude words in the main dictionary

            If Application.CheckSpelling( _
                Word:=rngWord.Text, _
                IgnoreUppercase:=False) = False Then

                    'Apply style as desired
                    rngWord.Bold = True

            End If

        End If

    Next rngWord

   'restore custom dictionary
   CustomDictionaries.Add FileName:="BENUTZER.DIC"

   'Stores end time in variable "EndTime"
   EndTime = Timer

   'Prints execution time in the debug window
   MsgBox ("Execution time in seconds: " & EndTime - StartTime)

End Sub

Answer 3

I'll answer this question myself: I'm afraid there is indeed no solution for this - as far as I can judge from what I found on the net the main dictionary can't be excluded..

But, I came to a quite different solution, which actually does the same and works well enough for me..

'macro name: ReformatListMatches
'purpose: compares words from document with words from file
'author: kay cichini
'date: 2012-01-04
'licence: cc by-nc-sa

'specifications:
'before running the macro, add a commandbar called "mycombar" and assign the macro "ReformatListMatches" to it,
'run line 8 one time, then disable it, then save file to a template (.dot) and store it at your templates' folder.
'if you don't want a command bar, just skip the above part and don't run line 8!

Sub ReformatListMatches()

'CommandBars("mycombar").Controls(1).TooltipText = "calls procedure that re-formats words that match word list"
'this sets tooltip info, run this only once (!!), otherwise you will be asked to save changes to the dot file
'everytime you close a word doc.

time_start = Timer()

If MsgBox("Re-format matches?" & vbLf & " " & vbLf & "..may take some time" & vbLf & "..be patient! (the active window will be temporarily invisible to speed up process)", vbOKCancel + vbQuestion, "SpKursiv") = vbOK Then

Dim vntArrWords As Variant
Dim lngI As Long
Dim strText As String
Dim strPathFile As String
Dim lngFN As Long

strPathFile = "C:\LogoXP\SP_words_tab.txt"
'the database with names to compare

lngFN = FreeFile
Open strPathFile For Binary As lngFN
 strText = Space(LOF(lngFN))
 Get lngFN, 1, strText
Close lngFN

System.Cursor = wdCursorWait

vntArrWords = Split(strText, vbCrLf, -1, 1)

ActiveWindow.Visible = False

With ActiveDocument.Content.Find
  .ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .MatchCase = False
  .MatchWholeWord = True
  .MatchWildcards = False
  .MatchSoundsLike = False
  .MatchAllWordForms = False
  .Replacement.ClearFormatting
  .Replacement.Text = "^&"               'replaces match with the original string (but with new format!)
  .Replacement.Font.Italic = True        'here i determine the new format
  For lngI = 0 To UBound(vntArrWords)
    .Text = Trim(vntArrWords(lngI))
    .Execute Replace:=wdReplaceAll
  Next
End With

ActiveWindow.Visible = True

time_end = Timer()

MsgBox "finished!" & vbLf & "(calculation time (mm:ss) = " & time_end - time_start & ")"

Else: Exit Sub
End If

End Sub