Re: Search Word Doc, save file as by TDM
TDM
Sat Feb 25 11:18:28 CST 2006
<sicapitan@gmail.com> wrote in message
news:1140495122.746147.310870@g14g2000cwa.googlegroups.com...
>I have about 12,000 documents which need to be searched.
>
> I have one main keyword "Booking" to get all the docs, but then I need
> to search for "ORDER NO :" and copy the rest of the line, then "DATE :"
> and copy whats left on that line into a variable.
>
> So I can get to the point where I can open all files ending in .doc in
> folders and subfolders
>
> but the "ORDER NO" and the ":" are far away from each other, and I need
> what text is after it until the end of the line. Then I need to store
> that information as a string
>
> and then save the filename as something else
>
> If there is a free tool already witten that'd be good, but i dont think
> there is, so its vbscript. Can someone help?
>
Not sure why, but I decided to take this one on. Use at your own
risk. This script will enumerate the file system from the starting point you
set,
currently set at C:\temp, but you set it to what you like, UNC should
work as well. Then searchh for word(.doc) files. Then, it will look for
"ORDER NO"
in the document(s) and return the complete line the text is found on. You
can then
do whatever you like with that line(string). But that is up to you.
Sorry, I am not big on comments but if you need help, post back
to the group.
TDM
Option Explicit
Dim objFso
Dim objWord
Dim objStartFolder
Dim iCtr
Dim ary
Dim aryDocsFound()
Dim aryOrdersFound()
Dim strFindFiles
Dim strStringToFind
Dim s
Dim ss
Const wdGoToLine = 3
Const wdGoToPage = 1
Const wdCollapseEnd = 0
Const wdGoToRelative = 2
Const wdFindContinue = 1
Const wdActiveEndPageNumber = 3
Const wdStartOfRangeColumnNumber = 16
Const wdHorizontalPositionRelativeToPage = 5
Const wdHorizontalPositionRelativeToTextBoundary = 7
Const wdEndOfRangeColumnNumber = 17
Const wdEndOfRangeRowNumber = 14
Const wdFirstCharacterColumnNumber = 9
Const wdFirstCharacterLineNumber = 10
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
Set objWord = WScript.CreateObject("Word.Application")
Set objStartFolder = objFso.GetFolder("C:\temp")
strFindFiles = ".doc"
iCtr = 0
' Check for being run from cscript versus wscript. Cscript best
' for echo's
If InStr(1, LCase(WScript.Fullname), "cscript", 1) = 0 Then
WScript.Echo "Script MUST be run from ""Cscript"" : C:\>cscript " &
WScript.ScriptFullName
WScript.Quit
End If
WScript.Echo "Searching for files matching : " & strFindFiles
WScript.Echo "File(s) found : " & findDocs(objStartFolder, strFindFiles)
strStringToFind = "ORDER NO"
For Each ary In aryDocsFound
If ary <> "" Then
ss = Split(ary, ",", -1, 1)
WScript.Echo "Search of " & ss(1) & vbCrLf & "Returned : " &
searchDoc(ss(1), strStringToFind) & vbCrLf & vbCrLf
End If
Next
Set objFso = Nothing
Set objWord = Nothing
Set objStartFolder = Nothing
WScript.Quit
'********************************************************************************************************
Function searchDoc(strFilePath, strStringToFind)
Dim strResult
WScript.Echo "Searching file : " & strFilePath & ", for : " &
strStringToFind
objWord.Visible = True
objWord.Documents.Open strFilePath
Call resetSearch(objWord)
strResult = findString(strStringToFind, objWord)
objWord.Documents.Close
searchDoc = strResult
End Function
'********************************************************************************************************
Function findDocs(Folder, srchString)
' This function will enumerate all files in a folder and match for
' srchString. The information is then stuffed in an Array for later
' processing
Dim S
Dim T
Dim objSubFolders
Dim objSubFolder
Dim objFiles
Dim objFile
Dim lngFSize
Set objFiles = Folder.Files
If objFiles.Count <> 0 Then
For Each objFile In objFiles
If Instr(1, LCase(objFile), srchString, 1) <> 0 Then
lngFSize = lngFSize + objFile.Size
Redim Preserve aryDocsFound(iCtr)
aryDocsFound(iCtr) = " *** Doc Found," & objFile & "," &
FormatNumber(objFile.Size, 0)
iCtr = iCtr + 1
End If
Next
End If
Set objSubFolders = Folder.SubFolders
If objSubFolders.Count <> 0 Then
For Each objSubFolder In objSubFolders
T = T & objSubFolder & vbCrLf
Next
S = S & vbCrLf
For Each objSubFolder In objSubFolders
T = T & findDocs(objSubFolder, srchString)
Next
End If
findDocs = iCtr
End Function
'********************************************************************************************************
Function findString(strStringToFind, objWord)
Dim objRange
Dim objSelection
Dim strTmp
Set objRange = objWord.ActiveDocument.Content
Set objSelection = objWord.Selection
strTmp = ""
With objRange.Find
.MatchCase = False
.MatchWildcards = True
.Execute(strStringToFind)
If .Found = True Then
objSelection.GoTo wdGoToPage, wdGoToRelative,
.Parent.Information(wdActiveEndPageNumber)
objSelection.GoTo wdGoToLine, wdGoToRelative,
.Parent.Information(wdFirstCharacterLineNumber) - 1
objSelection.Bookmarks("\LINE").Range.Select
strTmp = Trim(objSelection.Text)
Else
strTmp = "String not Found"
End If
End With
Set objRange = Nothing
Set objSelection = Nothing
findString = strTmp
End Function