Word Magic

				
'**************************************
' Name: Word Magic
' Description:This program allows simple desktop access the the Microsoft Word spelling and thesaurus engine using OLE Automation.
You can Spell Check, Produce Anangrams, use the Thesaurus and look up the meaning of words. THIS IS A COMPLETE WORKING APPLICATION
' By: Richard Lowe
'
' Assumes:Must have Microsoft Word Installed
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=2043&lngWId=1'for details.'**************************************

'===========================================================================
'Start a new project
'add a ComboBox named cboInput
'add a ListBox named lstDisplay
'add a Command Button named cmdHelp caption Help
'add a Command Button named cmdExit caption Exit
'add 4 Command Buttons (command array) named 
'cmdAction(0)	caption Spelling
'cmdAction(1)	caption Wildcard
'cmdAction(2)	caption Anagarm
'cmdAction(3)	Caption Lookup
'In the Project/References menu option tick the reference for
'Microsoft Word 8.0 Object Library
'===========================================================================
'paste the following code
Option Explicit
'============================================================
'== Author : Richard Lowe
'== Date : June 99
'== Contact : riklowe@hotmail.com
'============================================================
'== Desciption
'==
'== This program enable quick and easy desktop access to
'== the Microsoft Word spelling and thesaurus engine.
'==
'============================================================
'== Version History
'============================================================
'== 1.0 06-Jun-99 RL Initial Release. Spelling Only
'== 1.1 07-Jun-99 RL Added Widcard, Anagram and Lookup
'== 1.2 08-Jun-99 RL Added Help 
'============================================================
'------------------------------------------------------------
'Define constants
'------------------------------------------------------------
Const HeightLimit = 5000
Const WidthLimit = 5640
'------------------------------------------------------------
'Dimension variables
'------------------------------------------------------------
Dim objMsWord As Word.Application
Dim SugList As SpellingSuggestions
Dim sug As SpellingSuggestion
Dim synInfo As SynonymInfo
Dim synList As Variant
Dim AntList As Variant
Private Sub cmdAction_Click(Index As Integer)
'------------------------------------------------------------
' dimension local variables
'------------------------------------------------------------
Dim strTemp As String
Dim blnRet As Boolean
Dim iCount As Integer
'------------------------------------------------------------
' Asign an error handler
'------------------------------------------------------------
On Error GoTo eh_Trap:
'------------------------------------------------------------
' If cboInput has changed, add it as an entry to the list
'------------------------------------------------------------
 If cboInput.List(0) <> cboInput Then
cboInput.AddItem cboInput, 0
 End If
 
'------------------------------------------------------------
'Assign the objMsWord object reference to the Word application
'------------------------------------------------------------
 Set objMsWord = New Word.Application
 
'------------------------------------------------------------
'Due to a bug, you have to open a file to use GetSpellingSuggestions
'This is documented in Q169545 on microsoft knowledge base
'------------------------------------------------------------
 objMsWord.WordBasic.FileNew'open a doc
 objMsWord.Visible = False'hide the doc
 
'------------------------------------------------------------
' clear display area
'------------------------------------------------------------
 lstDisplay.Clear
 
'------------------------------------------------------------
' select which button has been pressed
'------------------------------------------------------------
 Select Case Index
 Case 0
'------------------------------------------------------------
'Spelling
'------------------------------------------------------------
blnRet = objMsWord.CheckSpelling(cboInput)
'------------------------------------------------------------
'if incorrectly spelt, check for suggestions. Iterate and display
'------------------------------------------------------------
If blnRet = True Then
 lstDisplay.AddItem "OK"
Else
 Set SugList = objMsWord.GetSpellingSuggestions(cboInput, _
 SuggestionMode:=wdSpelling)
 
 If SugList.Count = 0 Then
lstDisplay.AddItem "No suggestions"
 Else
For Each sug In SugList
 lstDisplay.AddItem sug.Name
Next sug
 End If
 
End If
 Case 1
'------------------------------------------------------------
'WildCard
'------------------------------------------------------------
Set SugList = objMsWord.Application.GetSpellingSuggestions(cboInput, _
SuggestionMode:=wdWildcard)
'------------------------------------------------------------
'If entries found, Iterate and display
'------------------------------------------------------------
If SugList.Count = 0 Then
 lstDisplay.AddItem "No suggestions"
Else
 For Each sug In SugList
lstDisplay.AddItem sug.Name
 Next sug
 
End If
 Case 2
'------------------------------------------------------------
'Anagram
'------------------------------------------------------------
Set SugList = objMsWord.GetSpellingSuggestions(cboInput, _
SuggestionMode:=wdAnagram)
'------------------------------------------------------------
'If entries found, Iterate and display
'------------------------------------------------------------
If SugList.Count = 0 Then
 lstDisplay.AddItem "No suggestions"
Else
 For Each sug In SugList
lstDisplay.AddItem sug.Name
 Next sug
End If
 Case 3
'------------------------------------------------------------
'Lookup
'------------------------------------------------------------
'------------------------------------------------------------
'Assign the synInfo object reference to the Word Synonym Information
'------------------------------------------------------------
Set synInfo = objMsWord.SynonymInfo(cboInput)
lstDisplay.AddItem "--- MEANING ---"
'------------------------------------------------------------
'If entries found, Iterate and display
'------------------------------------------------------------
If synInfo.MeaningCount >= 2 Then
 synList = synInfo.MeaningList
 For iCount = 1 To UBound(synList)
lstDisplay.AddItem synList(iCount)
 Next iCount
Else
 lstDisplay.AddItem "None"
End If
lstDisplay.AddItem "--- SYNONYM ---"
'------------------------------------------------------------
'If entries found, Iterate and display
'------------------------------------------------------------
If synInfo.MeaningCount >= 2 Then
 synList = synInfo.SynonymList(2)
 For iCount = 1 To UBound(synList)
lstDisplay.AddItem synList(iCount)
 Next iCount
Else
 lstDisplay.AddItem "None"
End If
Set synInfo = Nothing
 End Select
 
'------------------------------------------------------------
'Clean exit point
'------------------------------------------------------------
eh_exit:
 objMsWord.Quit
 Set objMsWord = Nothing
 cboInput.SetFocus
Exit Sub
'------------------------------------------------------------
'Error Handler
'------------------------------------------------------------
eh_Trap:
 
 lstDisplay.AddItem Err & vbTab & Error$
 Resume eh_exit:
 
End Sub
Private Sub cmdExit_Click()
 Unload Me
End Sub
Private Sub cmdHelp_Click()
'------------------------------------------------------------
'Display help information in the viewing area
'------------------------------------------------------------
 lstDisplay.Clear
 
 lstDisplay.AddItem "Spelling "
 lstDisplay.AddItem "Enter a word into the box above, press 'Spelling'"
 lstDisplay.AddItem "Correctly spelt words will display 'OK'"
 lstDisplay.AddItem "Incorrectly spelt words will display a list of "
 lstDisplay.AddItem "choices that most closely match the word"
 lstDisplay.AddItem " "
 lstDisplay.AddItem "Wildcard "
 lstDisplay.AddItem "Enter a word into the box above, press 'Wildcard'"
 lstDisplay.AddItem "Use a ? to indicate an unkown letter"
 lstDisplay.AddItem "Use a * to indicate muliple unkown letters"
 lstDisplay.AddItem "Examples (?) - Cl?se, Un?no?n "
 lstDisplay.AddItem "Examples (*) - Cl*, C*e"
 lstDisplay.AddItem " "
 lstDisplay.AddItem "Anangram "
 lstDisplay.AddItem "Enter a word into the box above, press 'Anagram'"
 lstDisplay.AddItem "The program will find all words in the "
 lstDisplay.AddItem "dictionary containing those letters "
 lstDisplay.AddItem " "
 lstDisplay.AddItem "Lookup "
 lstDisplay.AddItem "Enter a word into the box above, press 'Lookup'"
 lstDisplay.AddItem "The program will find the meaning and synonym "
 lstDisplay.AddItem "for the word from the dictionary "
 lstDisplay.AddItem " "
 lstDisplay.AddItem "General "
 lstDisplay.AddItem "Double click on an entry in this list box"
 lstDisplay.AddItem "and it will be transfered to the box above."
 lstDisplay.AddItem "Use the up and down arrows on the keyboard "
 lstDisplay.AddItem "or select the arrow at the right hand side "
 lstDisplay.AddItem "of the above box, to scroll through all of "
 lstDisplay.AddItem "the word you have entered."
 lstDisplay.AddItem ""
 lstDisplay.AddItem "Please e-mail any comments / suggestions to"
 lstDisplay.AddItem "me - It's great to get feedback."
 lstDisplay.AddItem "My e-mail address is riklowe@hotmail.com"
 lstDisplay.AddItem ""
 
End Sub
Private Sub Form_Load()
 cboInput.Clear
 
End Sub
Private Sub Form_Resize()
'------------------------------------------------------------
'Do not let the screen size get to small, so that the button
'are always visible
'------------------------------------------------------------
 Select Case Me.WindowState
 Case vbNormal
If Me.Height < HeightLimit Then
 Me.Height = HeightLimit
End If
lstDisplay.Height = Me.Height - 1000
Me.Width = WidthLimit
 Case Else
 End Select
 
End Sub
Private Sub lstDisplay_DblClick()
'------------------------------------------------------------
'Move entry from listbox into combo box
'------------------------------------------------------------
 
 cboInput.AddItem lstDisplay, 0
 cboInput.ListIndex = 0
 lstDisplay.Clear
 cboInput.SetFocus
 
End Sub