M
m stroup
I have a table of words in an access db. I want to check word documents
against this list and highlight any words in the doc that match. This
procedure works but it takes way too long. Any suggestions?
Function Boldwords()
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objRg As Range
Dim strDoc As String
Dim db As Database
Dim rs As Recordset
strDoc = InputBox("Enter the path and file name of document. i.e.
f:\doc.doc")
Set objWord = New Word.Application
Set objDoc = objWord.Documents.Open(strDoc)
Set objRg = objDoc.Range
Set db = CurrentDb()
Set rs = db.OpenRecordset("tblWords", dbOpenDynaset)
rs.MoveFirst
Do While Not rs.EOF
Set objRg = objDoc.Range
With objRg.Find
.Text = " " & rs![Word] & " "
While .Execute
objRg.Font.Bold = wdToggle
Wend
End With
Set objRg = objRg.Document.Range
With objRg.Find
.Text = " " & rs![Word] & "."
While .Execute
objRg.Font.Bold = wdToggle
Wend
End With
rs.MoveNext
Loop
objWord.Documents(strDoc).Close SaveChanges:=wdSaveChanges
objWord.Quit
Set objRg = Nothing
Set objDoc = Nothing
Set objWord = Nothing
Set rs = Nothing
Set db = Nothing
End Function
against this list and highlight any words in the doc that match. This
procedure works but it takes way too long. Any suggestions?
Function Boldwords()
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objRg As Range
Dim strDoc As String
Dim db As Database
Dim rs As Recordset
strDoc = InputBox("Enter the path and file name of document. i.e.
f:\doc.doc")
Set objWord = New Word.Application
Set objDoc = objWord.Documents.Open(strDoc)
Set objRg = objDoc.Range
Set db = CurrentDb()
Set rs = db.OpenRecordset("tblWords", dbOpenDynaset)
rs.MoveFirst
Do While Not rs.EOF
Set objRg = objDoc.Range
With objRg.Find
.Text = " " & rs![Word] & " "
While .Execute
objRg.Font.Bold = wdToggle
Wend
End With
Set objRg = objRg.Document.Range
With objRg.Find
.Text = " " & rs![Word] & "."
While .Execute
objRg.Font.Bold = wdToggle
Wend
End With
rs.MoveNext
Loop
objWord.Documents(strDoc).Close SaveChanges:=wdSaveChanges
objWord.Quit
Set objRg = Nothing
Set objDoc = Nothing
Set objWord = Nothing
Set rs = Nothing
Set db = Nothing
End Function