Private Sub SpellCheck_Click() Dim objWord As Object Dim objDoc As Object Dim strResult As String Const QUOTE = """" On Error GoTo ErrorRoutine App.OleRequestPendingTimeout = 999999 Set objWord = GetObject("Word.Application") If TypeName(objWord) <> "Nothing" Then ' Word is already open Set objWord = GetObject(, "Word.Application") Else ' Create an instance of Word Set objWord = CreateObject("Word.Application") End If Select Case objWord.version 'Office 2000 and later Case "9.0", "10.0", "11.0", "14.0", "15.0" Set objDoc = objWord.Documents.Add(, , 1, True) 'Office 97 Case "8.0" Set objDoc = objWord.Documents.Add Case Else MsgBox "Sorry but your version of Word seems to be " & QUOTE & objWord.version _ & QUOTE & " and that version is not currently supported.", vbOKOnly + vbExclamation, "Spelling Checker" Exit Sub End Select objDoc.Content = Text1.Text objDoc.CheckSpelling objWord.Visible = False strResult = Left(objDoc.Content, Len(objDoc.Content) - 1) ' Reformat carriage returns strResult = Replace(strResult, Chr(13), Chr(13) & Chr(10)) If Text1.Text = strResult Then ' There were no errors, so give the user a ' visual signal that something happened MsgBox "No changes made", vbInformation + vbOKOnly, "Spelling Checker" End If 'Clean up objDoc.Close False Set objDoc = Nothing objWord.Application.Quit True Set objWord = Nothing ' Replace the selected text with the corrected text. It's important that ' this be done after the "Clean Up" because otherwise there are problems ' with the screen not repainting Text1.Text = strResult Exit Sub ErrorRoutine: Select Case Err.Number Case -2147221020 ' There's no instance of Word so continue processing in order to create one Resume Next Case 429 MsgBox "Word must be installed in order for this code to work", vbCritical + vbOKOnly, "Spelling Checker" End Select End Sub
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.