Find word files for occurances of 1000 set strings 4

[Fenrirshowl]

Hi guys

Here's one to get your brains around and multiple appreciation stars will be on offer!

Problem:

I have a 1000 strings to uniquely identify a list a people (currently held in excel or access). These people are a subset of approximately 20,000 people.

I need to search all of the word documents in a folder and pull out those that contain any of the 1000 strings. The total number of word documents that need to be review is "significant" - it will effectively be every letter or document written over a six year period to/or relating to any of the 20,000 population.

Time is also a factor as this needs doing within a week.

Doing this manually will therefore prove next to impossible and I will need to automate (hence the VB forum).

There will be several folders that need to be reviewed, with non standard locations, so I think defining the folder location by prompt will be required.

Opening each word document will obviously slow everything down but I do not know if you can perform these operations on a closed Word doc.

The files are on a separate server in another office - accessing files on these other servers is usually slow so any thoughts on minimising this problem will also be appreciated. If it's simple enough, I can email it to the other office for someone else to run to eliminate this issue.

Given the problem, I need far better code that I can currently write. IF I could get close I am sure that it would grind to a halt so please treat me as a complete novice on this one.

Thanks in advance

Fen

 

[JerryKlmns]

Look at
Application.FileSearch and specially TextOrProperty Property

 

[JerryKlmns]

Ooops!

Create a table in access or an array to hold those 1000 strings do the Application.FileSearch for each value. That might take ~ 1 ton of coffee I think!

 

[DirkStruan]

thread707-1269726 may help

D

 

[Fenrirshowl]

Thanks guys, that looks like what I need, though I may be back.

Stars for both

Fen

 

[Fenrirshowl]

Back again.

I have lifted the code from thread707-1269726 and adapted it for my own purposes but am getting an error (438:Object doesn't support this property or method) when I try to open the word document/set wdoc using:

[/code]
Set wrd = CreateObject("Word.application")
wrd.Visible = True
Set db = CurrentDb()
Set rst = db.OpenRecordset("Words") 'name of my table
strDocName = Mid$(strItems, InStrRev(strItems, "\") + 1)
strDocLocation = strItems
Set wdoc = wrd.Open(FileName:=strItems, _
ReadOnly:=True, AddToRecentFiles:=False, _
Format:=wdOpenFormatAuto, Visible:=False)
[/code]

I don't know if having to amend

Set wrd = New Word.Application

which was used in the original thread is to blame but the macro crashed here until it was amended.

Any ideas. (I'm using Office 2000 applications)

Thanks in advance

Fen

 

[PHV]

Set wdoc = wrd[!].Documents[/!].Open(FileName:=strItems, _

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[Fenrirshowl]

Removal of the "documents" reduced my two error messages to one however, putting it back seems to have made it work.

It's now how it was earlier but with no errors rather than the two I was getting. Wierd.

Anyway, many thanks PHV

 

[Fenrirshowl]

Thanks to all for their assistance - the code works.

Given the number of searches being conducted I am wondering if there is any amendments that can be made to make the code run faster. (If not, I think I will set it off this weekend and leave it running).

Currently a list of 4 search words examining 4 docs in the parent folder and 2 docs a subfolder takes nearly a minute.

Sub ListWordDocsWithOccurrances()

On Error GoTo ErrHandler

Time1 = Timer

inptParent = InputBox("Enter the file path to the folder to be searched")
msgChild = MsgBox("Search subfolders?", vbYesNo)

Set db = CurrentDb()
Set wordlist = db.OpenRecordset("Words")
Do While Not wordlist.EOF
       
        Set Fs = Application.FileSearch
        Dim strFileSpec As String
        Dim strFolders As String
        strFileSpec = "*.doc"
        With Fs
          .NewSearch
          .LookIn = inptParent
          .filename = "*.doc"
          .filename = strFileSpec
          If msgChild = vbYes Then
              .SearchSubFolders = True
          Else
              .SearchSubFolders = False
          End If
          .TextOrProperty = wordlist.Fields("testword")   'Find Word doc(s) contatining this text
          If .Execute > 0 Then
              For i = 1 To .FoundFiles.Count    'enumerate through found files
                strItems = .FoundFiles(i)    'put file name in Variable
                Debug.Print strItems
        
                SysCmd acSysCmdSetStatus, "Loading Word documents"
                Set wrd = CreateObject("Word.application")

                Set rst = db.OpenRecordset("Results")
                strDocName = Mid$(strItems, InStrRev(strItems, "\") + 1)
                strDocLocation = strItems
                Set wdoc = wrd.Documents.Open(strItems, ReadOnly:=True)
        
        
                strDocText = wdoc.Content.FormattedText
                rst.AddNew
        
                rst.Fields("Document") = strDocName
        
                rst.Fields("Description") = wordlist.Fields("testword")
                rst.Fields("FileLocation") = strDocLocation
                rst.Fields("EDate") = Date
                rst.Update
                wrd.Quit
            
              Next
            
              Set wrd = Nothing
              SysCmd acSysCmdClearStatus
            End If
        End With
            
    wordlist.MoveNext
Loop
            
Time2 = Timer
MsgBox "Time taken: " & Round((Time2 - Time1) / 60, 2) & "mins"
            
ExitHere:
          Exit Sub
ErrHandler:
        
        
          Debug.Print Err, Err.Description, Err.HelpFile
          Resume ExitHere
        
    
End Sub

Thanks again

Fen

 

[JerryKlmns]

Fenrirshowl

I gave it a go, pls check it
And a question do you need the word document found to open while you searching? if not then remove anything concerning Word.Application

Sub ListWordDocsWithOccurrances()

On Error GoTo ErrHandler

Dim DB As DAO.Database
Dim rstWords As DAO.Recordset
Dim rstResults As DAO.Recordset
Dim fso As Object   'Use late binding for safety
Dim FS As Object    'Use late binding for safety
Dim FSFound As Object    'Use late binding for safety
Dim wrd As Object   'Use late binding for safety
Dim wdoc As Object  'Use late binding for safety
Dim inptParent As String
Dim msgChild As VbMsgBoxResult
Dim Time1, strItems As String, strDocName As String, strDocText As String
Time1 = Timer

inptParent = InputBox("Enter the path to the folder to be searched")
If inptParent = "" Then inptParent = "C:\" ' No input from user
msgChild = MsgBox("Search subfolders?", vbYesNo) 'Do you allow this option to the user?

Set DB = CurrentDb()
Set rstWords = DB.OpenRecordset("Words", dbOpenForwardOnly)
Set rstResults = DB.OpenRecordset("Results", dbOpenForwardOnly, dbAppendOnly)
Set wrd = CreateObject("Word.Application")
Set FS = CreateObject("Application.FileSearch")
Set fso = CreateObject("Scripting.FileSystemObject")
Do While Not rstWords.EOF
    With FS
        .NewSearch
        .LookIn = inptParent
        .FileType = 3 'msoFileTypeWordDocuments
        If msgChild = vbYes Then
            .SearchSubFolders = True
        Else
            .SearchSubFolders = False
        End If
        .TextOrProperty = rstWords.Fields("testword")   'Find Word doc(s) contatining this text
        If .Execute > 0 Then
            For Each FSFound In .FoundFiles
                strItems = FSFound    'put file name in Variable
                Debug.Print strItems
                SysCmd acSysCmdSetStatus, "Loading Word documents"
                'strDocName = Mid$(strItems, InStrRev(strItems, "\") + 1) 'InStrRev is for Access 2000 and above
                strDocName = fso.GetFileName(strItems) 'Access 97
                Set wdoc = wrd.Documents.Open(strItems, ReadOnly:=True) 'You open here the doc
                strDocText = wdoc.Content.FormattedText 'What's the use of this ?
                rstResults.AddNew
                rstResults.Fields("Document") = strDocName
                rstResults.Fields("Description") = rstWords.Fields("testword")
                rstResults.Fields("FileLocation") = fso.GetParent(strItems)
                rstResults.Fields("EDate") = Date
                rstResults.Update
                wdoc.Close 'You close the document her.
                Set wdoc = Nothing 'What was its use?
            Next
            SysCmd acSysCmdClearStatus
        End If
    End With
    rstWords.MoveNext
Loop

ExitHere:
    Set fso = Nothing
    Set FS = Nothing
    wrd.Quit
    Set wrd = Nothing
    If Not rstResults Is Nothing Then
        If rstResults.StillExecuting Then
            rstResults.CancelUpdate
            rstResults.Close
        End If
        Set rstResults = Nothing
    End If
    If Not rstWords Is Nothing Then
        rstWords.Close
        Set rstWords = Nothing
    End If
    Set DB = Nothing
    MsgBox "Time taken: " & Round((Timer - Time1) / 60, 2) & "mins"
    Exit Sub

ErrHandler:
    MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & Err.HelpFile
    Resume ExitHere
End Sub

 

[Fenrirshowl]

Hi Jerry

Many thanks for taking a look. ADO recordsets etc are currently beyond me but I am happy to trust code that works from others.....

 Dim DB As DAO.Database

causes a problem: "Compile Error: User defined type not defined"

Is it the version of Access that is causing this problem? (I seem to recall an ADO vs DAO question at some point but never delved into the issue as I almost never use either).

Fen

 

[PHV]

When in VBE, menu Tools -> References ...
Tick the Microsoft DAO 3.# Library

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[Fenrirshowl]

Thanks PHV

Ok, now getting more error messages mainly referring to VBLr6.chm which I can see is a file on my C drive. Does this mean I need some more references checked (please note the references had not been changed since Access was installed so I appreciate there may be a list of them).

If it's nothing to do with references I will post more detail about the error.

Fen

 

[Fenrirshowl]

In addition to the above post, the error message is:

91
Object variable or with loop variable not set
<pathname>VBLr6.chm

This only has the OK msgbox input available and I can't get enough time to break out of the macro - is there another keyboard combination to force the break macro?

Fen

 

[Fenrirshowl]

(See previous 2 posts)

I killed it with Task Manager and removed the error handling line:

1st error is from

Set FS = CreateObject("Application.FileSearch")

Error:

Run time error 429: ActiveX component cant create object.

Doesn't really mean anything to me.

This error flagged before the Error "91" above but the code was able to continue running.

 

[PHV]

Replace this:
Set FS = CreateObject("Application.FileSearch")
with this:
Set FS = Application.FileSearch

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[Fenrirshowl]

Sorted!

Question: why did it work before and not now in the revised verion?

Next error is from

For Each FSFound In .FoundFiles

Error 424 Object required.

Which I find strange as FSFound is defined and an object (?)

 

[JerryKlmns]

Ok,

Looks like it was full of errors (and I out of coffee)
I did check it and now runs.

Sub ListWordDocsWithOccurrances()

On Error GoTo ErrHandler

Dim DB As DAO.Database
Dim rstWords As DAO.Recordset
Dim rstResults As DAO.Recordset
Dim fso As Object
Dim FS As Object
Dim inptParent As String
Dim iCount As Long
Dim msgChild As VbMsgBoxResult
Dim Time1, strItems As String
Time1 = Timer

inptParent = InputBox("Enter the path to the folder to be searched")
If inptParent = "" Then inptParent = "C:\" ' No input from user
msgChild = MsgBox("Search subfolders?", vbYesNo) 'Do you allow this option to the user?

Set DB = CurrentDb()
Set rstWords = DB.OpenRecordset("Words", dbOpenForwardOnly)
Set rstResults = DB.OpenRecordset("Results", dbOpenDynaset)
Set FS = Application.FileSearch
Set fso = CreateObject("Scripting.FileSystemObject")
Do While Not rstWords.EOF
    With FS
        .NewSearch
        .LookIn = inptParent
        .FileType = 3 'msoFileTypeWordDocuments
        If msgChild = vbYes Then
            .SearchSubFolders = True
        Else
            .SearchSubFolders = False
        End If
        .TextOrProperty = rstWords.Fields("TestWord")   'Find Word doc(s) contatining this text
        If .Execute > 0 Then
            For iCount = 1 To .FoundFiles.Count
                strItems = .FoundFiles(iCount) 'put file name in Variable
                rstResults.AddNew
                rstResults.Fields("Document") = fso.GetFileName(strItems)
                rstResults.Fields("Description") = rstWords.Fields("TestWord")
                rstResults.Fields("FileLocation") = fso.GetParentFolderName(strItems)
                rstResults.Fields("EDate") = Date
                rstResults.Update
            Next
            SysCmd acSysCmdClearStatus
        End If
    End With
    rstWords.MoveNext
Loop

ExitHere:
    Set fso = Nothing
    Set FS = Nothing
    If Not rstResults Is Nothing Then
        rstResults.Close
        Set rstResults = Nothing
    End If
    If Not rstWords Is Nothing Then
        rstWords.Close
        Set rstWords = Nothing
    End If
    Set DB = Nothing
    MsgBox "Time taken: " & Round((Timer - Time1) / 60, 2) & "mins"
    Exit Sub

ErrHandler:
    MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & Err.HelpFile
    Resume ExitHere
End Sub

 

[Fenrirshowl]

Jerry

Thanks for having a second look - the revised code is magic and worthy of a second star as it now runs about 6 times faster.

May you always be with coffee!

Many, many thanks.

Fen

 

[Fenrirshowl]

Obviously can only award one star per post (but if anyone else is reading this please add one for me).

Ta