View Full Version : Indexing DOC with VBA

02-01-2006, 06:58 AM
Hi all,

Here is my projet:
- Intranet with more than 200000 WORD documents.
- PHP interface (Easy-PHP) + phpDIG


1- Catdoc doesn't work fine with me, especially with various Word formats and accents
2- I do not index a web site but also a directory subtree. Each subdir contains 3000 files.

1a- I use Word instead of Catdoc to extract the text objects and store them into text files, with a VBA script.
1b- I had to modify the code to replace file.txt by .doc with the links
1c- the VBA script generates an index.html file linking all text extractions used by the spider.

2- I had to modify some constants to make the spider accept a number of files in Level 1 more than 200000

1- the VBA text extractor takes roughly 2s per file
2- I used a 2x512Mo RAM to index the base. It took me more than 250 work hours.

The indexing time results are:
File number / Time (s)
1000 0,5
100000 4
150000 6
200000 10


Works better than catdoc but I don't warranty it for your purpose !

The aim of this script is to extract text objects from DOC files. Each directory contains a certain number of files. For instance, you can have "C:\DATA\shelf01, C:\DATA\shelf02, ..." with every directory containing 3000 files.
For each DOC file is created a TXT file.
In each directory is created a index.html file containing links to the extractions.

Microsoft does not recommend the use of Office to automate processes, because of the conversational requests (a dialog box asking you for something). You have to look at you computer to watch if it is suspended. In my db it appended twice. If it occurs, just have to shut down WORD by clicking on the cross.

The script takes care of password protected and rights of the files. Any protected file will not be indexed.

The script is partially fault tolerant, i.e., if the program crashes, you just have to relaunch it. It will start at the beginning of the current directory.

Best Regards,

Jean-Christophe LECOQ

Sub GenerateINDEXHTML()

Dim ShelfList
Dim currentDir As String, currentWORDFile As String, currentTXTFile As String, lastFileProcessed As String
Dim excludedDir As Variant, excludedFiles As Variant
Dim tempres As String
Dim FTPBasePath As String, LogFileName As String, LogErrorFileName As String, CurrentProcessFile As String
Dim ExcludeDocFileName As String
Dim arrFiles As Variant, arrDir As Variant
Dim NumFiles As Long, NumDir As Long
Dim CurrentOpenedFileID As Long, IndexFileID As Long, LogFileID As Long
Dim LogErrorFileID As Long, CurrentProcessFileID As Long, ExcludeDocFileID As Long
Dim TotaDirToExclude As Long, TotalFileToExclude As Long
Dim i, j, k
Dim reloadWORDmax As Long, reloadWORDcounter As Long

Dim dirToDo As Boolean, canProcessFile As Boolean
Dim debugflag As Boolean
Dim ProcessNow As Boolean
Dim oApp As Object
Dim oWord As Object, oTxt As Object

' Where the files are supposed to be stored
FTPBasePath = "c:\FTP\documents\"

' Log file name
LogFileName = "C:\FTP\conv_dir.log"

' Log Error file name
LogErrorFileName = "C:\FTP\conv_err.log"

' Log the current file that is processed
CurrentProcessFile = "C:\FTP\conv_cur.log"

' where the file to exclude of the process are
ExcludeDocFileName = "C:\FTP\conv_exclude.log"

' debug flag
debugflag = True

' reload winWORd every x documents
reloadWORDmax = 200
reloadWORDcounter = 0

NumDir = GesDirList(FTPBasePath, arrDir)

' open and read the list of files to exclude
TotalFileToExclude = 0
If ("" <> Dir(ExcludeDocFileName)) Then
ExcludeDocFileID = FreeFile
Open ExcludeDocFileName For Input As #ExcludeDocFileID ' should test if the file exist
ReDim excludedFiles(0 To 1000) ' should redim if exceeding
Debug.Print "Building excluded file list..."
Do While Not EOF(ExcludeDocFileID)
Input #ExcludeDocFileID, excludedFiles(TotalFileToExclude)
TotalFileToExclude = TotalFileToExclude + 1
ReDim Preserve excludedFiles(0 To TotalFileToExclude)
Close #ExcludeDocFileID
End If

' check if there is already a log file
TotaDirToExclude = 0
LogFileID = FreeFile
If ("" = Dir(LogFileName)) Then
Open LogFileName For Output As #LogFileID
' open the log file and read it to get directories
Open LogFileName For Input As #LogFileID
ReDim excludedDir(0 To 100)
Debug.Print "Retrieving log file..."
Do While Not EOF(LogFileID)
Input #LogFileID, currentDir
excludedDir(TotaDirToExclude) = currentDir
TotaDirToExclude = TotaDirToExclude + 1
ReDim Preserve excludedDir(0 To TotaDirToExclude)
Close #LogFileID
End If

' read the last file processed
If (True = debugflag) Then
' set the file in process
Debug.Print "Process is set in debug mode."

If ("" <> Dir(CurrentProcessFile)) Then
CurrentProcessFileID = FreeFile
Open CurrentProcessFile For Input As #CurrentProcessFileID
Input #CurrentProcessFileID, lastFileProcessed
Close #CurrentProcessFileID
ProcessNow = False
Debug.Print "No last file processed."
ProcessNow = True
End If
' process file in any case
ProcessNow = True
End If

Debug.Print "Let's go..."

' list of the shelfs
For i = 1 To NumDir

currentDir = FTPBasePath & arrDir(i)
Debug.Print "Processing " & currentDir

' is the directory excluded ?
dirToDo = True
If (0 <> TotaDirToExclude) Then
For k = 0 To (TotaDirToExclude)
If (0 <> InStr(excludedDir(k), currentDir)) Then
Debug.Print "directory already done ! skipping..."
dirToDo = False
Exit For
End If
End If

If (True = dirToDo) Then
NumFiles = GetFileList(currentDir, "*.doc", arrFiles)

' generate a new text file for index.html
fileName = currentDir & "\index.html"
IndexFileID = FreeFile
Open fileName For Output As #IndexFileID

Print #IndexFileID, "<!DOCTYPE HTML PUBLIC>"
Print #IndexFileID, "<html><head><title>Liste</title></head>"
Print #IndexFileID, "<BODY><TABLE>"

If (NumFiles > 0) Then
For j = 1 To NumFiles
' stopping the current WORD session if needed
If (reloadWORDcounter >= reloadWORDmax) Then
' quit WORD, without changing anything
oApp.Quit SaveChanges:=wdDoNotSaveChanges
Set oApp = Nothing
reloadWORDcounter = 0
End If

' starting a new WORD session
If (reloadWORDcounter = 0) Then
Set oApp = CreateObject("Word.Application")
oApp.Visible = False
oApp.DisplayAlerts = False
'disable spell and grammar checking
oApp.Options.CheckGrammarAsYouType = False
oApp.Options.CheckSpellingAsYouType = False
oApp.Options.CheckGrammarWithSpelling = False
' do not update OLE links
oApp.Options.UpdateLinksAtOpen = False
End If

reloadWORDcounter = reloadWORDcounter + 1

' name of the word file
currentWORDFile = currentDir & "\" & arrFiles(j)

' build a txt equivalent file
If (0 <> InStr(Left(Right(currentWORDFile, 4), 3), ".")) Then
currentTXTFile = LCase(Left(currentWORDFile, Len(currentWORDFile) - 4)) & ".txt"
End If
tempres = currentTXTFile
k = InStr(tempres, "\")
If (0 <> k) Then
tempres = Right(tempres, Len(tempres) - k)
End If
Loop Until (0 = k)

canProcessFile = True

' is the file excluded ?
If (TotalFileToExclude > 0) Then
For k = 0 To (TotalFileToExclude)
If (0 <> InStr(excludedFiles(k), currentWORDFile)) Then
Debug.Print "the file " & currentWORDFile & " is excluded ! skipping..."
canProcessFile = False
Exit For
End If
End If

ProcessNow = True

' can the process restart ?
If (True = debugflag) Then
If (False = ProcessNow) Then
If (Len(lastFileProcessed) > 0) Then
' is it the current file ?
If (0 <> InStr(lastFileProcessed, currentWORDFile)) Then
Debug.Print "Restarting process from " & currentWORDFile
ProcessNow = True
End If
Debug.Print "No crash before, starting now."
ProcessNow = True
End If
' store the name of the current file in case of crash
CurrentProcessFileID = FreeFile
Open CurrentProcessFile For Output As #CurrentProcessFileID
Print #CurrentProcessFileID, currentWORDFile
Close #CurrentProcessFileID
End If
End If

If ((True = canProcessFile) And (True = ProcessNow)) Then
On Error GoTo OpenErrorHandler
Set oWord = oApp.Documents.Open(fileName:=currentWORDFile, ConfirmConversions:=False, _
AddToRecentFiles:=False, ReadOnly:=True, _

If (True = canProcessFile) Then
oWord.ShowGrammaticalErrors = False
CurrentOpenedFileID = FreeFile
Open currentTXTFile For Output As #CurrentOpenedFileID
Close #CurrentOpenedFileID
Set oTxt = oApp.Documents.Open(fileName:=currentTXTFile, AddToRecentFiles:=False)
oTxt.ShowGrammaticalErrors = False
oTxt.range.Text = oWord.range.Text
If (True = canProcessFile) Then
End If

oWord.Close SaveChanges:=wdDoNotSaveChanges
Set oWord = Nothing
Set oTxt = Nothing

End If 'canProcessFile (reading a file generates problem)
End If 'canProcessFile (file excluded)

If (True = canProcessFile) Then
Print #IndexFileID, "<TR><TD><A href=" & tempres & _
">" & arrFiles(j) & " converti en txt " & "</A></TD></TR>"
End If


End If

Print #IndexFileID, "</TABLE></BODY></html>"
Close #IndexFileID

' open log file in an append mode, to add a new shelf
LogFileID = FreeFile
Open LogFileName For Append As #LogFileID
Print #LogFileID, currentDir
Close #LogFileID

End If

Set oApp = Nothing

Debug.Print "OVER !"
Exit Sub

' append error in log file
LogErrorFileID = FreeFile
Open LogErrorFileName For Append As #LogErrorFileID
Print #LogErrorFileID, Time & ": Error " & Err.Number & " on " & currentWORDFile
canProcessFile = False
Close #LogErrorFileID
If (Err.Number = -2147023170) Then
' critical error, relaod WINWORD
Debug.Print "critical error ! reloading WINWORD..."
reloadWORDcounter = reloadWORDmax
End If
Resume Next
End Sub

Function GesDirList(ByVal sPath As String, arrFiles) As Long
Dim NextReDim As Long, nFound As Long
Dim currentRep
NextReDim = 10
nFound = 0

ReDim arrFiles(0 To NextReDim)
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

currentRep = Dir(sPath, vbDirectory)
Do While currentRep <> ""
If currentRep <> "." And currentRep <> ".." Then
If (GetAttr(sPath & currentRep) And vbDirectory) = vbDirectory Then
nFound = nFound + 1
arrFiles(nFound) = currentRep
If nFound >= NextReDim Then
NextReDim = NextReDim + NextReDim
ReDim Preserve arrFiles(0 To NextReDim)
End If
End If
End If
currentRep = Dir()
ReDim Preserve arrFiles(0 To nFound)
GesDirList = nFound
End Function

Function GetFileList(ByVal sPath As String, SearchStr As String, arrFiles) As Long
Dim fileName As String
Dim NextReDim As Long, nFound As Long, bAdd As Boolean
Dim LCaseSearchStr As String
LCaseSearchStr = LCase(SearchStr)
NextReDim = 100

ReDim arrFiles(0 To NextReDim)
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
nFound = 0
fileName = Dir(sPath & SearchStr)
Do While Len(fileName) > 0
Select Case True
Case fileName = "."
Case fileName = ".."
Case Else
nFound = nFound + 1
arrFiles(nFound) = fileName
If nFound >= NextReDim Then
NextReDim = NextReDim + 100
ReDim Preserve arrFiles(0 To NextReDim)
End If
End Select
fileName = Dir()
ReDim Preserve arrFiles(0 To nFound)
GetFileList = nFound
End Function