D
Designingsally
Hi This is a pretty big big. I ll be extremely extremely glad if someone
corrects this code. I found this code somewhere in the internet.
Thanks a ton in advance.
The code is as follow:
Dim objDocument As Document
Dim fs
Dim targets As Collection
Dim targetArray() As String
Dim indexTracker As Collection
'contains the count for each preposition as we search for new prepositions
'in a give sentence. This number is used by the server to determine which
'instance of a preposition to check if there are multiple occurances in the
'sentence.
Dim sentenceIterator As Integer
'with reference to objDocument.sentences
Dim wordIterator As Integer
'with reference to objDocument.sentences(sentenceIterator).words
Const confThreshold As Double = 0.1
Const Root As String = "C:\Prepositions"
Const perl As String = "C:\Perl\bin\perl.exe"
Const perlScript As String = Root & "\prepwin2.pl"
Const DoneFileLoc As String = Root & "\preposition.don"
Const OutputFile As String = Root & "\outputFile.txt"
Const TargetFile As String = Root & "\targets2.txt"
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub changeWordText(newWord As String)
'changes the text of the word currently selected by wordIterator
'(except any trailing spaces) to newWord
objDocument.Sentences(sentenceIterator).Words(wordIterator).Text = _
Replace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text, _
TrimSpace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text),
newWord)
End Sub
Private Sub Doze(ByVal lngPeriod As Long)
DoEvents
Sleep lngPeriod
End Sub
Function ReadFile(FileName As String) As String()
'adapted from http://www.jojo-zawawi.com
Dim Line As String
Dim Results() As String
Open FileName For Input As #1
i = 0
Do While Not EOF(1) 'Loop until end of file
Input #1, Line 'Read data into two variables
ReDim Preserve Results(i)
Results(i) = Line
i = i + 1
'MsgBox (Line) 'Show variable contents in message box
Loop
Close #1
ReadFile = Results()
End Function
Private Function ContainsItem(col As Collection, val As Variant) As Boolean
' obtained from www.vba-programmer.com
Dim itm As Variant
On Error Resume Next
itm = col.Item(val)
ContainsItem = Not (Err.Number = 5 Or Err.Number = 9)
On Error GoTo 0
End Function
Function TrimSpace(strInput As String) As String
' adapted from MSDN
' This procedure trims extra space from any part of
' a string.
Dim astrInput() As String
Dim astrText() As String
Dim strElement As String
Dim lngCount As Long
Dim lngIncr As Long
Dim temp As Boolean
bool = False
bool = (strInput = "")
'filter out unwanted carriage returns
strInput = Replace(strInput, vbLf, "")
strInput = Replace(strInput, vbCr, "")
If (Len(strInput) = 0) Then
TrimSpace = ""
GoTo TheEnd
End If
' Split passed-in string.
astrInput = Split(strInput)
' Resize second array to be same size.
ReDim astrText(UBound(astrInput))
' Initialize counter variable for second array.
lngIncr = LBound(astrInput)
' Loop through split array, looking for
' non-zero-length strings.
For lngCount = LBound(astrInput) To UBound(astrInput)
strElement = astrInput(lngCount)
If (Len(strElement) > 0) Then
' Store in second array.
astrText(lngIncr) = strElement
lngIncr = lngIncr + 1
End If
Next
' Resize new array.
ReDim Preserve astrText(LBound(astrText) To lngIncr - 1)
' Join new array to return string.
TrimSpace = Join(astrText)
TheEnd:
End Function
Function NextInstance() As String()
'Returns an array with three strings:
' -the status: "error", "no more", or "found mistake"
' -the preposition that is found
' -the sentence in which the error occurs
'
' sets the global word iterator to the location of the preposition, so it
' can be replaced
'Begin searching the current sentence (global sentence iterator) for the next
'preposition. If none found, move to the next sentence. Repeat until a
'preposition is found. If there are no more sentences, return "no more".
Dim ReturnVal(2) As String
Dim found As Boolean
found = False
'move wordIterator forward to avoid finding the same preposition twice
wordIterator = wordIterator + 1
While (sentenceIterator < objDocument.Sentences.Count + 1 And Not found)
If (GetNextTarget) Then
found = True
Else
sentenceIterator = sentenceIterator + 1
wordIterator = 1
Set indexTracker = New Collection
For i = 0 To UBound(targetArray)
indexTracker.Add 0, targetArray(i)
Next i
End If
Wend
If (Not found) Then
ReturnVal(0) = "No more"
ReturnVal(1) = ""
ReturnVal(2) = ""
Else
Dim sentence As String
ReturnVal(0) = "found mistake"
ReturnVal(1) =
TrimSpace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text)
sentence = TrimSpace(objDocument.Sentences(sentenceIterator))
ReturnVal(2) = Replace(sentence, """", "")
End If
NextInstance = ReturnVal()
End Function
Function GetNextTarget() As Boolean
'move the word iterator forward until it hits the end of the sentence, or
'or it hits a preposition. Return true if we hit a preposition; false
otherwise.
Dim found As Boolean
found = False
While (wordIterator < objDocument.Sentences(sentenceIterator).Words.Count +
1 And Not found)
theWord =
TrimSpace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text)
If (ContainsItem(targets, theWord)) Then
found = True
'increase the index for this word
newCount = indexTracker.Item(theWord) + 1
indexTracker.Remove (theWord)
indexTracker.Add newCount, theWord
'indexTracker.Item(theWord) = indexTracker
Else
wordIterator = wordIterator + 1
End If
Wend
GetNextTarget = found
End Function
Sub Init()
'Think this needs to change
Set objDocument = ActiveDocument
Set targets = New Collection
Set indexTracker = New Collection
Set fs = CreateObject("Scripting.FileSystemObject")
'remove the file perl will write, if it exists
If fs.FileExists(OutputFile) Then
Kill OutputFile
End If
If fs.FileExists(DoneFileLoc) Then
Kill DoneFileLoc
End If
sentenceIterator = 1
wordIterator = 1
targetArray = ReadFile(TargetFile)
For i = 0 To UBound(targetArray)
targets.Add targetArray(i), targetArray(i)
indexTracker.Add 0, targetArray(i)
Next i
'MsgBox ("size of target array: " & (UBound(targetArray) + 1))
End Sub
Function getAlternatives(target As String, sentence As String) As String()
'remove the file perl will write, if it exists
If fs.FileExists(OutputFile) Then
Kill OutputFile
End If
If fs.FileExists(DoneFileLoc) Then
'MsgBox ("Done file exists before call")
TryAgain:
On Error GoTo ErrorHandler
Kill DoneFileLoc
End If
GoTo EndHandler
ErrorHandler:
errorCount = errorCount + 1
Resume TryAgain
EndHandler:
Index = indexTracker(target)
perlcall = perl & " " & perlScript & " " & target & " " & Index & " " & """"
& sentence & """"
'MsgBox (perlcall)
ID = Shell(perlcall, vbHide)
If fs.FileExists(DoneFileLoc) Then
MsgBox ("Done file exists after call")
'Kill DoneFileLoc
End If
'MsgBox (perlcall)
Dim Results() As String
'loop until the program finishes, then read the file it creates
Dim DoneFile As Boolean
DoneFile = False
While (Not DoneFile)
If fs.FileExists(DoneFileLoc) Then
DoneFile = True
Else
Doze 100
End If
Wend
Results() = ReadFile(OutputFile)
getAlternatives = Results()
End Function
Sub FindMistake()
If (Not UserForm1.Visible) Then
UserForm1.Show (0)
End If
UserForm1.Caption = "Searching for an error..."
UserForm1.SentenceBox.Text = "Please be patient; this will take a few
moments..."
UserForm1.CorrectionListBox.Clear
UserForm1.IgnoreButton.Enabled = False
UserForm1.ReplaceButton.Enabled = False
UserForm1.Repaint
'MsgBox ("findmistake!")
Dim foundMistake As Boolean
foundMistake = False
While (Not foundMistake)
Dim mistake() As String
Dim alternatives() As String
mistake() = NextInstance()
'mistake(0) holds the status of the NextInstance() call
'mistake(1) holds the preposition under consideration
'mistake(2) holds the context sentence of the preposition under
consideration
temp = mistake(2)
If (mistake(0) = "No more") Then
UserForm1.Hide
MsgBox ("Preposition Check Complete")
'remove the file perl will write, if it exists
If fs.FileExists(OutputFile) Then
Kill OutputFile
End If
If fs.FileExists(DoneFileLoc) Then
'MsgBox ("Done file exists before call")
TryAgain:
On Error GoTo ErrorHandler
Kill DoneFileLoc
End If
GoTo EndHandler
ErrorHandler:
errorCount = errorCount + 1
Resume TryAgain
EndHandler:
End
End If
If (mistake(0) = "Error") Then
MsgBox ("Unknown Error")
End If
alternatives() = getAlternatives(mistake(1), mistake(2))
'check for errors
If (UBound(alternatives) < 0) Then
MsgBox ("Error reading from perl script.")
End
End If
If (alternatives(0) = "Error:") Then
UserForm1.Hide
MsgBox ("Error: " & alternatives(1))
End
End If
Dim confidence As Double
confidence = val(alternatives(0))
If (confidence > confThreshold And Not alternatives(1) = mistake(1)) Then
foundMistake = True
End If
Wend
'Build up sentence word by word, inserting *'s at correct places.
Dim wrongSentence As String
Dim wrongWord As String
wrongSentence = "{\rtf1{\colortbl;\red0\green0\blue0;\red255\green20\blue20;}"
For i = 1 To wordIterator - 1
wrongSentence = wrongSentence &
objDocument.Sentences(sentenceIterator).Words(i).Text
Next i
wrongWord = objDocument.Sentences(sentenceIterator).Words(wordIterator).Text
wrongSentence = wrongSentence & Replace(wrongWord, TrimSpace(wrongWord),
"{\f1\cf2\b " & TrimSpace(wrongWord) & "}")
For i = wordIterator + 1 To
objDocument.Sentences(sentenceIterator).Words.Count
wrongSentence = wrongSentence &
objDocument.Sentences(sentenceIterator).Words(i).Text
Next i
wrongSentence = wrongSentence & "}"
'UserForm1.SentenceBox.Text = wrongSentence
UserForm1.SentenceBox.TextRTF = wrongSentence
UserForm1.IgnoreButton.Caption = "Ignore"
For i = 1 To UBound(alternatives)
UserForm1.CorrectionListBox.AddItem (alternatives(i))
Next i
UserForm1.CorrectionListBox.ListIndex = 0
UserForm1.IgnoreButton.Enabled = True
UserForm1.ReplaceButton.Enabled = True
UserForm1.Caption = "Suggested Prepositions"
UserForm1.Repaint
End Sub
Sub PrepositionCorrect()
'UserForm1.IgnoreButton.Caption = "Start"
UserForm1.IgnoreButton.Enabled = True
UserForm1.ReplaceButton.Enabled = False
Call Init
Call FindMistake
End Sub
corrects this code. I found this code somewhere in the internet.
Thanks a ton in advance.
The code is as follow:
Dim objDocument As Document
Dim fs
Dim targets As Collection
Dim targetArray() As String
Dim indexTracker As Collection
'contains the count for each preposition as we search for new prepositions
'in a give sentence. This number is used by the server to determine which
'instance of a preposition to check if there are multiple occurances in the
'sentence.
Dim sentenceIterator As Integer
'with reference to objDocument.sentences
Dim wordIterator As Integer
'with reference to objDocument.sentences(sentenceIterator).words
Const confThreshold As Double = 0.1
Const Root As String = "C:\Prepositions"
Const perl As String = "C:\Perl\bin\perl.exe"
Const perlScript As String = Root & "\prepwin2.pl"
Const DoneFileLoc As String = Root & "\preposition.don"
Const OutputFile As String = Root & "\outputFile.txt"
Const TargetFile As String = Root & "\targets2.txt"
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub changeWordText(newWord As String)
'changes the text of the word currently selected by wordIterator
'(except any trailing spaces) to newWord
objDocument.Sentences(sentenceIterator).Words(wordIterator).Text = _
Replace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text, _
TrimSpace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text),
newWord)
End Sub
Private Sub Doze(ByVal lngPeriod As Long)
DoEvents
Sleep lngPeriod
End Sub
Function ReadFile(FileName As String) As String()
'adapted from http://www.jojo-zawawi.com
Dim Line As String
Dim Results() As String
Open FileName For Input As #1
i = 0
Do While Not EOF(1) 'Loop until end of file
Input #1, Line 'Read data into two variables
ReDim Preserve Results(i)
Results(i) = Line
i = i + 1
'MsgBox (Line) 'Show variable contents in message box
Loop
Close #1
ReadFile = Results()
End Function
Private Function ContainsItem(col As Collection, val As Variant) As Boolean
' obtained from www.vba-programmer.com
Dim itm As Variant
On Error Resume Next
itm = col.Item(val)
ContainsItem = Not (Err.Number = 5 Or Err.Number = 9)
On Error GoTo 0
End Function
Function TrimSpace(strInput As String) As String
' adapted from MSDN
' This procedure trims extra space from any part of
' a string.
Dim astrInput() As String
Dim astrText() As String
Dim strElement As String
Dim lngCount As Long
Dim lngIncr As Long
Dim temp As Boolean
bool = False
bool = (strInput = "")
'filter out unwanted carriage returns
strInput = Replace(strInput, vbLf, "")
strInput = Replace(strInput, vbCr, "")
If (Len(strInput) = 0) Then
TrimSpace = ""
GoTo TheEnd
End If
' Split passed-in string.
astrInput = Split(strInput)
' Resize second array to be same size.
ReDim astrText(UBound(astrInput))
' Initialize counter variable for second array.
lngIncr = LBound(astrInput)
' Loop through split array, looking for
' non-zero-length strings.
For lngCount = LBound(astrInput) To UBound(astrInput)
strElement = astrInput(lngCount)
If (Len(strElement) > 0) Then
' Store in second array.
astrText(lngIncr) = strElement
lngIncr = lngIncr + 1
End If
Next
' Resize new array.
ReDim Preserve astrText(LBound(astrText) To lngIncr - 1)
' Join new array to return string.
TrimSpace = Join(astrText)
TheEnd:
End Function
Function NextInstance() As String()
'Returns an array with three strings:
' -the status: "error", "no more", or "found mistake"
' -the preposition that is found
' -the sentence in which the error occurs
'
' sets the global word iterator to the location of the preposition, so it
' can be replaced
'Begin searching the current sentence (global sentence iterator) for the next
'preposition. If none found, move to the next sentence. Repeat until a
'preposition is found. If there are no more sentences, return "no more".
Dim ReturnVal(2) As String
Dim found As Boolean
found = False
'move wordIterator forward to avoid finding the same preposition twice
wordIterator = wordIterator + 1
While (sentenceIterator < objDocument.Sentences.Count + 1 And Not found)
If (GetNextTarget) Then
found = True
Else
sentenceIterator = sentenceIterator + 1
wordIterator = 1
Set indexTracker = New Collection
For i = 0 To UBound(targetArray)
indexTracker.Add 0, targetArray(i)
Next i
End If
Wend
If (Not found) Then
ReturnVal(0) = "No more"
ReturnVal(1) = ""
ReturnVal(2) = ""
Else
Dim sentence As String
ReturnVal(0) = "found mistake"
ReturnVal(1) =
TrimSpace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text)
sentence = TrimSpace(objDocument.Sentences(sentenceIterator))
ReturnVal(2) = Replace(sentence, """", "")
End If
NextInstance = ReturnVal()
End Function
Function GetNextTarget() As Boolean
'move the word iterator forward until it hits the end of the sentence, or
'or it hits a preposition. Return true if we hit a preposition; false
otherwise.
Dim found As Boolean
found = False
While (wordIterator < objDocument.Sentences(sentenceIterator).Words.Count +
1 And Not found)
theWord =
TrimSpace(objDocument.Sentences(sentenceIterator).Words(wordIterator).Text)
If (ContainsItem(targets, theWord)) Then
found = True
'increase the index for this word
newCount = indexTracker.Item(theWord) + 1
indexTracker.Remove (theWord)
indexTracker.Add newCount, theWord
'indexTracker.Item(theWord) = indexTracker
Else
wordIterator = wordIterator + 1
End If
Wend
GetNextTarget = found
End Function
Sub Init()
'Think this needs to change
Set objDocument = ActiveDocument
Set targets = New Collection
Set indexTracker = New Collection
Set fs = CreateObject("Scripting.FileSystemObject")
'remove the file perl will write, if it exists
If fs.FileExists(OutputFile) Then
Kill OutputFile
End If
If fs.FileExists(DoneFileLoc) Then
Kill DoneFileLoc
End If
sentenceIterator = 1
wordIterator = 1
targetArray = ReadFile(TargetFile)
For i = 0 To UBound(targetArray)
targets.Add targetArray(i), targetArray(i)
indexTracker.Add 0, targetArray(i)
Next i
'MsgBox ("size of target array: " & (UBound(targetArray) + 1))
End Sub
Function getAlternatives(target As String, sentence As String) As String()
'remove the file perl will write, if it exists
If fs.FileExists(OutputFile) Then
Kill OutputFile
End If
If fs.FileExists(DoneFileLoc) Then
'MsgBox ("Done file exists before call")
TryAgain:
On Error GoTo ErrorHandler
Kill DoneFileLoc
End If
GoTo EndHandler
ErrorHandler:
errorCount = errorCount + 1
Resume TryAgain
EndHandler:
Index = indexTracker(target)
perlcall = perl & " " & perlScript & " " & target & " " & Index & " " & """"
& sentence & """"
'MsgBox (perlcall)
ID = Shell(perlcall, vbHide)
If fs.FileExists(DoneFileLoc) Then
MsgBox ("Done file exists after call")
'Kill DoneFileLoc
End If
'MsgBox (perlcall)
Dim Results() As String
'loop until the program finishes, then read the file it creates
Dim DoneFile As Boolean
DoneFile = False
While (Not DoneFile)
If fs.FileExists(DoneFileLoc) Then
DoneFile = True
Else
Doze 100
End If
Wend
Results() = ReadFile(OutputFile)
getAlternatives = Results()
End Function
Sub FindMistake()
If (Not UserForm1.Visible) Then
UserForm1.Show (0)
End If
UserForm1.Caption = "Searching for an error..."
UserForm1.SentenceBox.Text = "Please be patient; this will take a few
moments..."
UserForm1.CorrectionListBox.Clear
UserForm1.IgnoreButton.Enabled = False
UserForm1.ReplaceButton.Enabled = False
UserForm1.Repaint
'MsgBox ("findmistake!")
Dim foundMistake As Boolean
foundMistake = False
While (Not foundMistake)
Dim mistake() As String
Dim alternatives() As String
mistake() = NextInstance()
'mistake(0) holds the status of the NextInstance() call
'mistake(1) holds the preposition under consideration
'mistake(2) holds the context sentence of the preposition under
consideration
temp = mistake(2)
If (mistake(0) = "No more") Then
UserForm1.Hide
MsgBox ("Preposition Check Complete")
'remove the file perl will write, if it exists
If fs.FileExists(OutputFile) Then
Kill OutputFile
End If
If fs.FileExists(DoneFileLoc) Then
'MsgBox ("Done file exists before call")
TryAgain:
On Error GoTo ErrorHandler
Kill DoneFileLoc
End If
GoTo EndHandler
ErrorHandler:
errorCount = errorCount + 1
Resume TryAgain
EndHandler:
End
End If
If (mistake(0) = "Error") Then
MsgBox ("Unknown Error")
End If
alternatives() = getAlternatives(mistake(1), mistake(2))
'check for errors
If (UBound(alternatives) < 0) Then
MsgBox ("Error reading from perl script.")
End
End If
If (alternatives(0) = "Error:") Then
UserForm1.Hide
MsgBox ("Error: " & alternatives(1))
End
End If
Dim confidence As Double
confidence = val(alternatives(0))
If (confidence > confThreshold And Not alternatives(1) = mistake(1)) Then
foundMistake = True
End If
Wend
'Build up sentence word by word, inserting *'s at correct places.
Dim wrongSentence As String
Dim wrongWord As String
wrongSentence = "{\rtf1{\colortbl;\red0\green0\blue0;\red255\green20\blue20;}"
For i = 1 To wordIterator - 1
wrongSentence = wrongSentence &
objDocument.Sentences(sentenceIterator).Words(i).Text
Next i
wrongWord = objDocument.Sentences(sentenceIterator).Words(wordIterator).Text
wrongSentence = wrongSentence & Replace(wrongWord, TrimSpace(wrongWord),
"{\f1\cf2\b " & TrimSpace(wrongWord) & "}")
For i = wordIterator + 1 To
objDocument.Sentences(sentenceIterator).Words.Count
wrongSentence = wrongSentence &
objDocument.Sentences(sentenceIterator).Words(i).Text
Next i
wrongSentence = wrongSentence & "}"
'UserForm1.SentenceBox.Text = wrongSentence
UserForm1.SentenceBox.TextRTF = wrongSentence
UserForm1.IgnoreButton.Caption = "Ignore"
For i = 1 To UBound(alternatives)
UserForm1.CorrectionListBox.AddItem (alternatives(i))
Next i
UserForm1.CorrectionListBox.ListIndex = 0
UserForm1.IgnoreButton.Enabled = True
UserForm1.ReplaceButton.Enabled = True
UserForm1.Caption = "Suggested Prepositions"
UserForm1.Repaint
End Sub
Sub PrepositionCorrect()
'UserForm1.IgnoreButton.Caption = "Start"
UserForm1.IgnoreButton.Enabled = True
UserForm1.ReplaceButton.Enabled = False
Call Init
Call FindMistake
End Sub