Extract Unique Spelling Errors

[swaggerbox]

I got this code below from a website (http://word.tips.net/T001465_Pulling...ng_Errors.html). What it does is extract ALL the spelling errors in an MS WORD document even if it repeats. I only want the unique terms. Any ideas?

Sub GetSpellingErrors()    
 
Dim DocThis As Document    
Dim iErrorCnt As Integer    
Dim J As Integer    
 
Set DocThis = ActiveDocument    
 
Documents.Add    
 
iErrorCnt = DocThis.SpellingErrors.Count
 
For J = 1 To iErrorCnt        
 
 Selection.TypeText Text:=DocThis.SpellingErrors(J)
 
 Selection.TypeParagraph
 
Next J
 
End Sub

[Talis]

Try this:

Function checkIt(strDone As String, docNew As Document) As Boolean
    Set docNew = ActiveDocument
    With docNew.Content.Find
        .Text = strDone
        .Execute
        checkIt = .Found
    End With
End Function

Sub GetSpellingErrors()
Dim docThis As Document, docNew As Document
    Dim iErrorCnt As Integer
    Dim iCount As Integer
Set docThis = ActiveDocument
    Set docNew = Documents.Add
  With docThis
        iErrorCnt = .SpellingErrors.Count
        For iCount = 1 To iErrorCnt
            If Not checkIt(.SpellingErrors(iCount), docNew) Then
                Selection.TypeText Text:=.SpellingErrors(iCount)
                Selection.TypeParagraph
            End If
        Next iCount
    End With
End Sub

[swaggerbox]

Talis:

This is great! Thanks a lot!

[amirza01]

Hello guys,

Thanks for the above script it works great; however, is it possible for the script to also capture the fonts, bold, italics, bold-italics, etc. in other words, the spelling mistakes that are exported into the new document must preserve the original formatting.

[gmaxey]

Well, this will do what you want (sort of). However, if you want "miselled" "miselled", ""miselled" each listed and any other unknown but near limitless variations, it would be much more difficult if not impossible.

Sub GetSpellingErrorsII()
Dim oDoc As Document, oDocList As Document
Dim oCol As New Collection
Dim lngIndex As Long, lngErrors As Long
Dim oRng As Range
  Set oDoc = ActiveDocument
  Set oDocList = Documents.Add
    With oDoc
      lngErrors = .SpellingErrors.Count
      For lngIndex = 1 To lngErrors
         On Error Resume Next
         oCol.Add .SpellingErrors(lngIndex), .SpellingErrors(lngIndex)
         If Err.Number = 0 Then
            Set oRng = oDocList.Range
            oRng.Collapse wdCollapseEnd
            oRng.FormattedText = .SpellingErrors(lngIndex).FormattedText
            oRng.InsertAfter vbCr
         End If
         Err.Clear
      Next lngIndex
    End With
lbl_Exit:
  Exit Sub
End Sub