Extract Unique Spelling Errors

[swaggerbox]

I got this code below from a website (http://word.tips.net/T001465_Pulling_Out_Spelling_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