Import Word Text Into Access (Look in SubFolders) 1

[Accel45]

I am using the code below to retrieve text from Word documents into Access. (Code was posted by RickSpr in thread 707-65952) The code works fine. However, I would like to modify the code so that it also will retrieve text from Word documents in all SubFolders at the same time.

Can someone help me with the modifications, please.

accel45


Public Sub LoadAllDocuments(Folder As String)
Dim strDocFile As String
Dim strDocName As String
Dim strDocText As String
Dim wrd As Word.Application
Dim wdoc As Word.Document
Dim db As DAO.Database
Dim rst As DAO.Recordset

DoCmd.Hourglass True
SysCmd acSysCmdSetStatus, "Loading Word documents"
Set wrd = New Word.Application
Set db = CurrentDb()
Set rst = db.OpenRecordset("Documents")
strDocFile = Dir$(Folder & "\*.doc")
Do While Len(strDocFile) <> 0
strDocName = Left$(strDocFile, InStrRev(strDocFile, ".") - 1)
Set wdoc = wrd.Documents.Open(FileName:=Folder & "\" & strDocFile, _
ReadOnly:=True, AddToRecentFiles:=False, _
Format:=wdOpenFormatAuto, Visible:=False)
strDocText = wdoc.Content.FormattedText
rst.AddNew
rst.Fields("DocName") = strDocName
rst.Fields("DocText") = strDocText
rst.Update
strDocFile = Dir$()
Loop
wrd.Quit
Set wrd = Nothing
ErrorExit:
SysCmd acSysCmdClearStatus
DoCmd.Hourglass False
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbExclamation
Resume ErrorExit
End Sub

 

[CautionMP]

Accel45,
Check this thread: [navy]VBA Visual Basic for Applications (Microsoft) Forum: Looping through files - make recursive!? Help please[/navy] thread707-1077512.

Hope this helps,
CMP

(GMT-07:00) Mountain Time (US & Canada)

 

[Accel45]

CautionMP,

Thank you for the reply. I spent some time on the code and did some more searching with no luck.

Any Help?

accel45

 

[CautionMP]

Accel45,
How about using the [tt]FileSeach[/tt] object.
Microsoft: Access Modules (VBA Coding) Forum:
Examine File System For Files With Certain Names

CMP

(GMT-07:00) Mountain Time (US & Canada)

 

[Accel45]

CautionMP,

I found some code using the FileSeach object and I have attempted to make it work for me.

Thus far I can get the code to bring in one file from the selected location (eventhough there are other files) and that one file is posted to the table over and over until I use task manager to end Access. As of yet I have not been able to remedy the continous loop of one file and not bring in the remaining files. I think I'm closer than I was. Any pointers? Thank you for your help.

accel45

Code below is what I have so far...

Private Sub Command28_Click()
Dim strDocName As String
Dim strDocFile As String
Dim strDocText As String
Dim strDocLocation As String
Dim wrd As Word.Application
Dim wdoc As Word.Document
Dim db As DAO.Database
Dim rst As DAO.Recordset

Dim Fs As Object
Dim i As Integer
Dim strItems As String

Set Fs = Application.FileSearch
With Fs
.NewSearch
.Lookin = Me.FileLocation 'Path
.filename = "*.Doc" 'Search through all word document
.SearchSubFolders = True
.TextOrProperty = "*" 'Find Word doc(s) contatining this text

If .Execute > 0 Then
If MsgBox("There were " & .FoundFiles.Count & " " & "Files found in the " & .Lookin & " Folder" & vbCrLf & _
"Do you want to continue?", vbYesNo + vbQuestion, "Found Files") = vbYes Then
For i = 1 To .FoundFiles.Count 'enumerate through found files
strItems = .FoundFiles(i) 'put file name in Variable
Debug.Print strItems

'do something to the files
SysCmd acSysCmdSetStatus, "Loading Word documents"
Set wrd = New Word.Application
Set db = CurrentDb()
Set rst = db.OpenRecordset("tblHarvest")
'strDocFile = Dir$(Folder & "\*.doc")
Do While Len(Application.FileSearch.FoundFiles(i)) <> 0
'strDocName = Left$(strDocFile, InStrRev(strDocFile, ".") - 1)
strDocName = Mid$(Application.FileSearch.FoundFiles(i), InStrRev(Application.FileSearch.FoundFiles(i), "\") + 1)

strDocLocation = Application.FileSearch.FoundFiles(i)
Set wdoc = wrd.Documents.Open(filename:=Application.FileSearch.FoundFiles(i), _
ReadOnly:=True, AddToRecentFiles:=False, _
Format:=wdOpenFormatAuto, Visible:=False)
strDocText = wdoc.Content.FormattedText
rst.AddNew
rst.Fields("Document") = strDocName
rst.Fields("Description") = strDocText
rst.Fields("FileLocation") = strDocLocation
rst.Update
Loop
Next
wrd.Quit
Set wrd = Nothing
SysCmd acSysCmdClearStatus

End If
Else:
MsgBox "No Files Found"
End If
End With

End Sub

 

[PHV]

Why a Do While loop inside your For loop ?
Here a quick and dirty (typed, untested) correction:
...
Set Fs = Application.FileSearch
With Fs
.NewSearch
.LookIn = Me.FileLocation 'Path
.FileName = "*.Doc" 'Search through all word document
.SearchSubFolders = True
.TextOrProperty = "*" 'Find Word doc(s) contatining this text
If .Execute > 0 Then
If MsgBox("There were " & .FoundFiles.Count & " " & "Files found in the " & .LookIn & " Folder" & vbCrLf & _
"Do you want to continue?", vbYesNo + vbQuestion, "Found Files") = vbYes Then
For i = 1 To .FoundFiles.Count 'enumerate through found files
strItems = .FoundFiles(i) 'put file name in Variable
Debug.Print strItems

'do something to the files
SysCmd acSysCmdSetStatus, "Loading Word documents"
Set wrd = New Word.Application
Set db = CurrentDb()
Set rst = db.OpenRecordset("tblHarvest")
strDocName = Mid$(strItems, InStrRev(strItems, "\") + 1)
strDocLocation = strItems
Set wdoc = wrd.Documents.Open(FileName:=strItems, _
ReadOnly:=True, AddToRecentFiles:=False, _
Format:=wdOpenFormatAuto, Visible:=False)
strDocText = wdoc.Content.FormattedText
rst.AddNew
rst.Fields("Document") = strDocName
rst.Fields("Description") = strDocText
rst.Fields("FileLocation") = strDocLocation
rst.Update
Next
wrd.Quit
Set wrd = Nothing
SysCmd acSysCmdClearStatus
End If
Else
MsgBox "No Files Found"
End If
End With
...

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