Private Declare Function GetInputState Lib "user32.dll" () As Long
Private Type ChangeALLType
OriginalWord As String
ReplaceWord As String
End Type
Dim ChangeAllWords() As ChangeALLType
Dim IgnoreAllWords() As String
Public Event Error()
Public Event StatusChange()
Public Event CurrentWord()
Public Event ChangeWord()
Public Event Finished()
Public Event Alternate()
Dim WSP As Workspace
Dim wordDBS As Database
Dim wRST As Recordset
Dim uShowEachWord As Boolean
Dim wordCHANGED As Boolean
Dim uShowAlternate As Boolean
Dim uError As String
Dim uStatus As String
Dim uText As String
Dim uTextOriginal As String
Dim uWord As String
Dim nWORD As String
Dim nPOS As Long
Dim uWordPos As Long
Dim CloseClicked As Boolean
Private Sub RefreshAlternate()
If uShowAlternate Then
cmdADD.Left = 3000
cmdADD.Width = 855
'imgALT.Left = 3960
imgALT.Visible = True
Else
cmdADD.Left = 3120
cmdADD.Width = 975
imgALT.Visible = False
'imgALT.Left = -300
End If
End Sub
Property Let ShowEachWord(nShow As Boolean)
uShowEachWord = nShow
End Property
Property Get ShowEachWord() As Boolean
ShowEachWord = uShowEachWord
End Property
Property Let ShowAlternate(nAlt As Boolean)
uShowAlternate = nAlt
Call RefreshAlternate
End Property
Property Get ShowAlternate() As Boolean
ShowAlternate = uShowAlternate
End Property
Property Get WordPos() As Long
WordPos = uWordPos
End Property
Public Sub SpellCheck()
Dim odStatus As String
uText = Trim$(uText)
If Len(uText) = 0 Then
uError = "Nothing To Check"
RaiseEvent Error
RaiseEvent Finished
Exit Sub
End If
If Len(Dir$(App.Path & "\words.mdb")) = 0 Then
If Len(Dir$(App.Path & "\words.txt")) = 0 Then
uError = "Dictionary Cannot Be Created"
RaiseEvent Error
RaiseEvent Finished
End If
End If
nPOS = 1
uWordPos = 0
uWord = ""
nWORD = ""
wordCHANGED = False
CloseClicked = False
ReDim ChangeAllWords(0 To 0)
ReDim IgnoreAllWords(0 To 0)
odStatus = Open_WordDB
If odStatus <> "Ok" Then
uError = odStatus
RaiseEvent Error
RaiseEvent Finished
End If
Call Get_Next_Word
End Sub
Public Sub Get_Next_Word()
Dim i As Long
Dim ii As Long
Dim a As Integer
Dim pPERC As Integer
Dim pWIDTH As Long
On Local Error Resume Next
cmdADD.Enabled = False
cmdCHANGE.Enabled = False
cmdIGNORE.Enabled = False
cmdIGNOREALL.Enabled = False
cmdCHANGEALL.Enabled = False
cmdCHANGETO.Enabled = False
nextWord:
DoEvents
pPERC = (nPOS / Len(uText)) * 100
If pPERC > 100 Then pPERC = 100
pWIDTH = (pPERC / 100) * Shape1.Width
If pWIDTH > Shape1.Width Then pWIDTH = Shape1.Width
Shape2.Width = pWIDTH
Shape2.Refresh
If CloseClicked Then
wordDBS.Close
Set wordDBS = Nothing
WSP.Close
Set WSP = Nothing
RaiseEvent Finished
Exit Sub
End If
If wordCHANGED Then
' if a word has changed, then the text will
' have been updated. The current nPOS may be in the
' middle of the text now.
' so move nPOS back to a space then add to
moveBACK:
If nPOS = 0 Then GoTo moveEND
If Mid$(uText, nPOS, 1) = "¼" Then GoTo moveEND
nPOS = nPOS - 1
GoTo moveBACK
' While nPOS > 0 And Mid$(uText, nPOS, 1) <> " "
' nPOS = nPOS - 1
' Wend
moveEND:
nPOS = nPOS + 1
End If
wordCHANGED = False
i = InStr(nPOS, uText & " ", " ", vbTextCompare)
ii = InStr(nPOS, uText, "¼", vbTextCompare)
If i = 0 And ii = 0 Then
wRST.Close
Set wRST = Nothing
wordDBS.Close
Set wordDBS = Nothing
WSP.Close
Set WSP = Nothing
RaiseEvent Finished
Exit Sub
End If
If ii < i And ii <> 0 Then i = ii
If i = 0 Then
wRST.Close
Set wRST = Nothing
wordDBS.Close
Set wordDBS = Nothing
WSP.Close
Set WSP = Nothing
RaiseEvent Finished
Exit Sub
End If
uWord = Mid$(uText, nPOS, i - nPOS)
uWord = Replace_Text(uWord, "¼", "")
If Len(uWord) = 0 Then
nPOS = i + 1
GoTo nextWord
End If
RemoveQuotesETC:
If Left$(uWord, 1) = "'" Or Left$(uWord, 1) = Chr$(34) Then
uWord = Right$(uWord, Len(uWord) - 1)
GoTo RemoveQuotesETC
End If
If Right$(uWord, 1) = "'" Or Right$(uWord, 1) = Chr$(34) Then
uWord = Left$(uWord, Len(uWord) - 1)
GoTo RemoveQuotesETC
End If
If Right$(uWord, 1) = "?" Or Right$(uWord, 1) = "!" Or Right$(uWord, 1) = "," Or Right$(uWord, 1) = "." Or Right$(uWord, 1) = ";" Or Right$(uWord, 1) = ":" Then
uWord = Left$(uWord, Len(uWord) - 1)
GoTo RemoveQuotesETC
End If
If Len(uWord) = 0 Then
nPOS = i + 1
GoTo nextWord
End If
lblWORD = uWord
lblWORD.Refresh
txtCHANGETO.Text = uWord
txtCHANGETO.Refresh
cmdCHANGETO.ToolTipText = "Change Word To " & txtCHANGETO.Text
uWordPos = nPOS
If uShowEachWord Then RaiseEvent CurrentWord
If Word_Exists(uWord) Then
' word exists by unique index
nPOS = i + 1
GoTo nextWord
End If
' word not found
' maybe in ignore list
If UBound(IgnoreAllWords) > 0 Then
For a = 1 To UBound(IgnoreAllWords)
If LCase$(IgnoreAllWords(a)) = LCase$(uWord) Then
' in ignore list
nPOS = i + 1
GoTo nextWord
End If
Next a
End If
Call Check_Word(uWord)
DoEvents
If CloseClicked Then
wRST.Close
Set wRST = Nothing
wordDBS.Close
Set wordDBS = Nothing
WSP.Close
Set WSP = Nothing
RaiseEvent Finished
Exit Sub
End If
nPOS = i + 1
If levenWords.ListCount = 1 Then
If LCase$(levenWords.List(0)) = LCase$(uWord) Then GoTo nextWord
End If
' word not found
' maybe in change all list
If UBound(ChangeAllWords) > 0 Then
For a = 1 To UBound(ChangeAllWords)
If LCase$(ChangeAllWords(a).OriginalWord) = LCase$(uWord) Then
RaiseEvent CurrentWord
DoEvents
For ii = 0 To levenWords.ListCount - 1
If LCase$(levenWords.List(ii)) = LCase$(ChangeAllWords(a).ReplaceWord) Then
levenWords.ListIndex = ii
Exit For
End If
Next ii
If ii > (levenWords.ListCount - 1) Then
' hmm not in list so add to it
levenWords.AddItem ChangeAllWords(i).ReplaceWord
levenWords.ListIndex = levenWords.ListCount - 1
End If
nWORD = levenWords.List(levenWords.ListIndex)
wordCHANGED = True
RaiseEvent ChangeWord
Exit Sub
End If
Next a
End If
levenWords.ListIndex = 0
Call levenWords_Click
RaiseEvent CurrentWord
cmdADD.Enabled = True
cmdCHANGE.Enabled = True
cmdIGNORE.Enabled = True
cmdIGNOREALL.Enabled = True
cmdCHANGEALL.Enabled = True
cmdCHANGETO.Enabled = True
End Sub
Property Let Text(nText As String)
uText = nText
uTextOriginal = uText
uText = Replace_Text(uText, vbCrLf, "¼¼")
uText = Replace_Text(uText, Chr$(9), "¼")
End Property
Property Get Word() As String
Word = uWord
End Property
Property Get NewWord() As String
NewWord = nWORD
End Property
Property Get Status() As String
Status = uStatus
End Property
Property Get ErrorMessage() As String
ErrorMessage = uError
End Property
Public Sub InitialiseWORDS()
Dim r As String
uStatus = "Initialising Words"
RaiseEvent StatusChange
r = Create_Word_Database
If r <> "OK" Then
uError = r
uStatus = "Failed To Initialise Words"
RaiseEvent Error
RaiseEvent StatusChange
Else
uError = ""
RaiseEvent StatusChange
End If
End Sub
Private Function Open_WordDB() As String
Dim wDB As String
On Local Error Resume Next
If Right$(App.Path, 1) = "\" Then
wDB = App.Path & "Words.mdb"
Else
wDB = App.Path & "\Words.mdb"
End If
If Len(Dir$(wDB)) = 0 Then
If Len(Dir$(App.Path & "\words.txt")) = 0 Then
Open_WordDB = "Cannot Find Words Database"
Exit Function
Else
Call InitialiseWORDS
End If
End If
Set WSP = DBEngine.Workspaces(0)
' database created with not errors
' open database and record set
Set wordDBS = WSP.OpenDatabase(wDB, False)
Set wRST = wordDBS.OpenRecordset("Words", dbOpenTable)
wRST.Index = "Word"
Open_WordDB = "Ok"
End Function
Private Function Word_Exists(iWord As String) As Boolean
On Local Error Resume Next
wRST.Seek "=", iWord
If wRST.NoMatch = False Then Word_Exists = True
End Function
Private Sub Check_Word(ByVal strWord As String)
On Local Error GoTo subFAIL
Dim SndxMatchRS As Recordset
Dim LdMax As Long
Dim lenTmp As Long
Dim cPhoneme As New clsPhoneme
Dim Soundex As String
Dim LD As Long
Dim i As Long
Dim threshold As Long
Dim strMATCH As String
' ensure word to search on
strWord = Trim$(strWord)
If strWord = vbNullString Then
uError = "No Word To Search On"
RaiseEvent Error
Set cPhoneme = Nothing
Exit Sub
End If
uStatus = "Searching..."
RaiseEvent StatusChange
'// Get the soundex of the input word
Soundex = cPhoneme.GetSoundexWord(strWord)
'// Now find all entries in the database which match the soundex of the input word
Set SndxMatchRS = wordDBS.OpenRecordset("SELECT [word] from Words WHERE " & _
"Soundex = " & _
Chr$(34) & Soundex & Chr$(34), _
dbOpenSnapshot)
'// Populate the Listbox (soundEXWords)
soundExWords.Clear
levenWords.Clear
With SndxMatchRS
While .EOF = False
If GetInputState <> 0 Then DoEvents
soundExWords.AddItem !Word
lenTmp = Len(!Word)
If lenTmp > LdMax Then LdMax = lenTmp
.MoveNext
Wend
End With
' if no words in soundex list then will not find any words in leven list
Private Function Create_New_Database(dBasePath As String, dBaseName As String, ReCreateOnColl As Boolean) As Boolean
On Local Error GoTo fcnFailed
Dim NewDatabase As Database
Dim l As String
l = Dir$(dBasePath & dBaseName)
If Len(l) <> 0 Then
If ReCreateOnColl = True Then
If Len(Dir$(dBasePath & dBaseName & "Bak")) > 0 Then
Kill dBasePath & dBaseName & "Bak"
End If
Name dBasePath & dBaseName As dBasePath & dBaseName & "Bak"
Else
Create_New_Database = True
Exit Function
End If
End If
Set NewDatabase = WSP.CreateDatabase(dBasePath & dBaseName, dbLangGeneral)
NewDatabase.Close
Set NewDatabase = Nothing
Create_New_Database = True
Exit Function
fcnFailed:
Set NewDatabase = Nothing
Create_New_Database = False
Exit Function
End Function
Private Function Create_New_Field(dBasePath As String, dBaseName As String, tblName As String, nFieldName As String, nFieldType As Long, nFieldIndexed As Boolean, nFieldUnique As Boolean, nFieldPrimary As Boolean, AlZLength As Boolean, nFieldPosition As Variant, nFieldAbutes As Variant, nFieldDefaultValue As Variant, nFieldSize As Variant, ReCreateOnColl As Boolean) As Boolean
On Local Error GoTo fcnFailed
Dim DBToAppend As Database
Dim TblToAppend As TableDef
Dim NewField As Field
Dim Ret1 As Boolean
Dim a As Integer
Dim SqlQ1 As String
Set DBToAppend = WSP.OpenDatabase(dBasePath & dBaseName, False)
Set TblToAppend = DBToAppend.TableDefs(tblName)
For a = 0 To DBToAppend.TableDefs(tblName).Fields.Count - 1
If LCase$(DBToAppend.TableDefs(tblName).Fields(a).Name) = LCase$(nFieldName) Then
