It still appears as if you're checking the spelling of one word at a time.
Here's a class module that I use:
-----BEGIN MODULE
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsSpellCheck"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private m_sTextToCheck As String
Private m_sTextCorrected As String
Public Enum PerformSpellCheckConstants
NoSpellingErrors = 1
CorrectionsMade = 2
CorrectionsNotMade = 3
AutomationError = 4
End Enum
Public Function PerformSpellCheck() As PerformSpellCheckConstants
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim bNoSpellingErrors As Boolean
Dim sTemp As String
On Error GoTo EH
Set oWordApp = New Word.Application
If Not oWordApp Is Nothing Then
Set oWordDoc = oWordApp.Documents.Add
End If
If oWordDoc Is Nothing Then
PerformSpellCheck = AutomationError
If Not oWordApp Is Nothing Then
oWordApp.Quit wdDoNotSaveChanges
Set oWordApp = Nothing
End If
Exit Function
End If
'Let's make sure there are spelling errors
bNoSpellingErrors = oWordApp.CheckSpelling(TextToCheck, , False)
If bNoSpellingErrors Then
PerformSpellCheck = NoSpellingErrors
'Make sure the original text is assigned to TextCorrected property
'in case this method's return value is not checked
m_sTextCorrected = TextToCheck
oWordDoc.Close wdDoNotSaveChanges
Set oWordDoc = Nothing
oWordApp.Quit wdDoNotSaveChanges
Set oWordApp = Nothing
Exit Function
End If
With oWordDoc
.Content.Text = TextToCheck
.Activate
.CheckSpelling , False, True
m_sTextCorrected = .Content.Text
'Word replaces CR/LFs with a CR and/or may append a CR to the end of
the text.
'This needs fixed.
m_sTextCorrected = Replace$(m_sTextCorrected, vbCr, vbCrLf, 1, -1,
vbBinaryCompare)
'Eliminate trailing CR/LFs from end of string. It's possible there
could be
'multiple pairs.
Do While Right$(m_sTextCorrected, 2) = vbCrLf
m_sTextCorrected = Left$(m_sTextCorrected,
Len(m_sTextCorrected) - 2)
Loop
'Now, we need to append the same number of CR/LFs as the original
string had.
sTemp = TextToCheck 'use temp variable so as not to modify original
string
Do While Right$(sTemp, 2) = vbCrLf
m_sTextCorrected = m_sTextCorrected & vbCrLf
sTemp = Left$(sTemp, Len(sTemp) - 2)
Loop
If StrComp(m_sTextCorrected, TextToCheck, vbBinaryCompare) = 0 Then
'If the strings are identical, corrections were not made because
'we already know there were spelling errors.
PerformSpellCheck = CorrectionsNotMade
Else
PerformSpellCheck = CorrectionsMade
End If
End With
'Make sure we clean up after ourselves
If Not oWordDoc Is Nothing Then
oWordDoc.Close wdDoNotSaveChanges
Set oWordDoc = Nothing
End If
If Not oWordApp Is Nothing Then
oWordApp.Quit wdDoNotSaveChanges
Set oWordApp = Nothing
End If
Exit Function
EH:
If Not oWordDoc Is Nothing Then
oWordDoc.Close wdDoNotSaveChanges
Set oWordDoc = Nothing
End If
If Not oWordApp Is Nothing Then
oWordApp.Quit wdDoNotSaveChanges
Set oWordApp = Nothing
End If
PerformSpellCheck = AutomationError
End Function
Public Property Get TextCorrected() As String
TextCorrected = m_sTextCorrected
End Property
Public Property Get TextToCheck() As String
TextToCheck = m_sTextToCheck
End Property
Public Property Let TextToCheck(sText As String)
m_sTextToCheck = sText
End Property
-----END MODULE
And here's an example of using it:
Dim oSpellCheck As clsSpellCheck
Set oSpellCheck = New clsSpellCheck
With oSpellCheck
.TextToCheck = Text1.Text
Select Case .PerformSpellCheck
Case CorrectionsMade
Text1.Text= .TextCorrected
Case AutomationError
MsgBox "Unable to perform spell check due to an
Automation error", vbCritical
End Select
End With
Set oSpellCheck = Nothing
Mike
