Set WordDoc = WordApp.Documents.Open(Filename:=File.Path, ReadOnly:=True)
Option Explicit
Public Word As Variant
Public WordsToFind As New Collection
Public WordsFound As New Collection
Public PrintRow As Integer
Public SubFolderCount As Integer
Public FileCount As Integer
Public FileSystem As Object
Public FolderName As String
Public WordApp As Object
Public WordDoc As Object
Public strDate As String
Public ErrorCount As Integer
Sub Search()
Dim HostFolder As String
Dim WordsFound(1 To 7)
Dim SearchWord As Integer
'Clear any collection in memory
Set WordsToFind = Nothing
Set FileSystem = Nothing
Set WordApp = Nothing
Set WordDoc = Nothing
'Create Word object
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
WordApp.DisplayAlerts = False
'In case rerun clear public variable
FileCount = 0
SubFolderCount = 0
ErrorCount = 0
'Clear Current Results Page
Worksheets("Results").Rows("2:" & Application.Max(Worksheets("Results").UsedRange.Rows.Count, 2)).Delete
Worksheets("Results").OLEObjects.Delete
'Setting the outputrow for printing results
PrintRow = 2
'Take sheet values used in program and assign to variables
With Worksheets("Search Interface")
HostFolder = .Range("D2").Value
'Location of Search Words on Sheet . Code is also dynamic so just increase range if you want to add words
For SearchWord = 8 To 12
If Not IsEmpty(.Range("C" & SearchWord)) Then
WordsToFind.Add .Range("C" & SearchWord)
End If
Next
End With
'If export spot is not empty then create folder which will then be zipped
If Not IsEmpty(Worksheets("Search Interface").Range("D4").Value) Then
With Worksheets("Search Interface").Range("D4")
FolderName = "SearchFile-" & Format(Now(), "mmddyyyyhhmmss")
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = .Value & "\" & "SearchFileZip " & strDate & ".zip"
'Make new Folder for zip
MkDir .Value & "\" & FolderName
End With
End If
'Run recursive folder search algorithm
Set FileSystem = CreateObject("Scripting.FileSystemObject")
RecursiveFolderSearch FileSystem.GetFolder(HostFolder)
'If export spot is not empty then create folder which will then be zipped then delete original
If Not IsEmpty(Worksheets("Search Interface").Range("D4").Value) Then
With Worksheets("Search Interface").Range("D4")
Zip_All_Files_in_Folder .Value & "\" & FolderName, .Value
FileSystem.deletefolder .Value & "\" & FolderName
End With
End If
'Clear Memory leaks
WordApp.Quit
Set WordsToFind = Nothing
Set FileSystem = Nothing
Set WordApp = Nothing
Set WordDoc = Nothing
End Sub
Sub RecursiveFolderSearch(Folder)
Dim SubFolder As Object
Dim File As Object
Dim PathName As String
For Each SubFolder In Folder.SubFolders
'This if then will help avoid shortcuts
If Folder.Attributes <> 64 Then
SubFolderCount = SubFolderCount + 1
RecursiveFolderSearch SubFolder
End If
Next
For Each File In Folder.Files
'This is to get around MS stupid 255 character string limit
If Len(File.Path) > 255 Then
PathName = GetShortFileName(File.Path)
Else
PathName = File.Path
End If
'Just some summary statistics about how many folders and files were actually reviewed in total
With Worksheets("Results")
.Range("E1").Value = "Subfolder Count: " & SubFolderCount
.Range("F1").Value = "Files Reviewed: " & FileCount
.Range("G1").Value = "Match Count: " & PrintRow - ErrorCount - 2
.Range("H1").Value = "Error Count: " & ErrorCount
End With
On Error GoTo ErrorHandler
'Not sure what is causing this error. Maybe old files saved in memory?
If Not Left(File.Name, 2) = "~$" Then
FileCount = FileCount + 1
Set WordsFound = Nothing
Select Case LCase(Right(File.Name, 4))
Case Is = "docx", ".doc", "docm", "dotm" 'Check if word document
10 Set WordDoc = WordApp.Documents.Open(Filename:=PathName, ReadOnly:=True)
WordDoc.ActiveWindow.View.ReadingLayout = False
'Select all and Check if word exists
WordApp.Selection.WholeStory
WordApp.Selection.Find.ClearFormatting
For Each Word In WordsToFind
With WordApp.Selection.Find
.Text = Word
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If .Execute Then
WordsFound.Add Word
End If
End With
Next
If WordsFound.Count > 0 Then
'outputting the results
With Worksheets("Results")
.Range("A" & PrintRow).Value = File.Name
'This will merge the words found to one cell
For Each Word In WordsFound
.Range("B" & PrintRow).Value = Word & "/" & .Range("B" & PrintRow).Value
Next
.Hyperlinks.Add Anchor:=.Range("C" & PrintRow), Address:=PathName, TextToDisplay:="Link - Click Here"
'Check if interface wants you to embed file
If Worksheets("Search Interface").Shapes("EmbedCheckBox").ControlFormat.Value = 1 Then
.OLEObjects.Add Filename:=PathName, Link:=False, DisplayAsIcon:=True, Left:=.Range("D" & PrintRow).Left + 30, Top:=.Range("D" & PrintRow).Top + 3, Width:=50, Height:=10
End If
'Send to export folder if directory isnt blank
If Not IsEmpty(Worksheets("Search Interface").Range("D4").Value) Then
FileSystem.CopyFile PathName, Worksheets("Search Interface").Range("D4").Value & "\" & FolderName & "\" & "Row Result - " & (PrintRow - 1) & ".docx", True
End If
End With
PrintRow = PrintRow + 1
End If
WordDoc.Close SaveChanges:=False
Set WordDoc = Nothing
End Select
End If
ContinueLoop:
Next
Exit Sub
ErrorHandler:
With Worksheets("Results")
.Range("A" & PrintRow).Value = File.Name
If IsEmpty(.Range("B" & PrintRow).Value) Then
.Range("B" & PrintRow).Value = "File triggered error -" & Err.Number & " " & Err.Description & " - VBA Line:" & Erl
ErrorCount = ErrorCount + 1 'I want to only count errors if the matching process was not able to go through
End If
.Hyperlinks.Add Anchor:=.Range("C" & PrintRow), Address:=PathName, TextToDisplay:="Link - Click Here"
End With
PrintRow = PrintRow + 1
If Not WordDoc Is Nothing Then
WordDoc.Close SaveChanges:=False
End If
Set WordDoc = Nothing
Resume ContinueLoop
End Sub
Option Explicit
Public Word As Variant
Public WordsToFind As New Collection
Public WordsFound As New Collection
Public PrintRow As Integer
Public SubFolderCount As Integer
Public FileCount As Integer
Public FileSystem As Object
Public FolderName As String
Public WordApp As Object
Public WordDoc As Object
Public strDate As String
Public ErrorCount As Integer
Sub Search()
Dim HostFolder As String
Dim WordsFound(1 To 7)
Dim SearchWord As Integer
'Clear any collection in memory
Set WordsToFind = Nothing
Set FileSystem = Nothing
Set WordApp = Nothing
Set WordDoc = Nothing
'Create a new Word object and isntance
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
WordApp.DisplayAlerts = False
'In case rerun clear public variable
FileCount = 0
SubFolderCount = 0
ErrorCount = 0
'Clear Current Results Page
Worksheets("Results").Rows("2:" & Application.Max(Worksheets("Results").UsedRange.Rows.Count, 2)).Delete
Worksheets("Results").OLEObjects.Delete
'Setting the outputrow for printing results
PrintRow = 2
'Take sheet values used in program and assign to variables
With Worksheets("Search Interface")
HostFolder = .Range("D2").Value
'Location of Search Words on Sheet . Code is also dynamic so just increase range if you want to add words
For SearchWord = 8 To 12
If Not IsEmpty(.Range("C" & SearchWord)) Then
WordsToFind.Add .Range("C" & SearchWord)
End If
Next
End With
'If export spot directory on sheet is not empty then create folder names/variables
If Not IsEmpty(Worksheets("Search Interface").Range("D4").Value) Then
With Worksheets("Search Interface").Range("D4")
FolderName = "SearchFile-" & Format(Now(), "mmddyyyyhhmmss")
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = .Value & "\" & "SearchFileZip " & strDate & ".zip" ' This variable is used in another subroutine made by ron bruin to zip files and is in another module
'Make new Folder for zip
MkDir .Value & "\" & FolderName
End With
End If
'Run recursive folder search algorithm
Set FileSystem = CreateObject("Scripting.FileSystemObject")
RecursiveFolderSearch FileSystem.GetFolder(HostFolder)
'If export spot as stated above is not empty then create the folder which will then be zipped then delete original
If Not IsEmpty(Worksheets("Search Interface").Range("D4").Value) Then
With Worksheets("Search Interface").Range("D4")
Zip_All_Files_in_Folder .Value & "\" & FolderName, .Value
FileSystem.deletefolder .Value & "\" & FolderName
End With
End If
'Clear Memory leaks just in case
WordApp.Quit
Set WordsToFind = Nothing
Set FileSystem = Nothing
Set WordApp = Nothing
Set WordDoc = Nothing
End Sub
Sub RecursiveFolderSearch(Folder)
Dim SubFolder As Object
Dim File As Object
Dim PathName As String
For Each SubFolder In Folder.SubFolders
'This if then will help avoid shortcuts based on my research
If Folder.Attributes <> 64 Then
SubFolderCount = SubFolderCount + 1
RecursiveFolderSearch SubFolder
End If
Next
For Each File In Folder.Files
'This is to get around MS stupid 255 character string limit
If Len(File.Path) > 255 Then
PathName = GetShortFileName(File.Path)
Else
PathName = File.Path
End If
'Just some summary statistics about how many folders and files were actually reviewed in total
With Worksheets("Results")
.Range("E1").Value = "Subfolder Count: " & SubFolderCount
.Range("F1").Value = "Files Reviewed: " & FileCount
.Range("G1").Value = "Match Count: " & PrintRow - ErrorCount - 2
.Range("H1").Value = "Error Count: " & ErrorCount
End With
On Error GoTo ErrorHandler
'Not sure what is causing this error. Maybe old files saved in memory because I dont see them in folder and they were deleted a while back? Either way need to not try and open files with these beginning two letters
If Not Left(File.Name, 2) = "~$" Then
FileCount = FileCount + 1
'just to clear memory of this variable before assigning new one by opening worddoc
Set WordsFound = Nothing
Select Case LCase(Right(File.Name, 4))
Case Is = "docx", ".doc", "docm", "dotm" 'Check if word document
'this line keeps tripping error mismatch around 200 files in and continues to do it. I say this line because erl returns 10 and all things accomplished seem to point to this.
10 Set WordDoc = WordApp.Documents.Open(Filename:=PathName, ReadOnly:=True)
WordDoc.ActiveWindow.View.ReadingLayout = False
'Select all and Check if word exists
WordApp.Selection.WholeStory
WordApp.Selection.Find.ClearFormatting
'loops through all possible search words in the keywords to search for and tries to find them in the word document
For Each Word In WordsToFind
With WordApp.Selection.Find
.Text = Word
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If .Execute Then
'Adds the word to the collection of words found which will later be printed on sheet
WordsFound.Add Word
End If
End With
Next
'if we have atleast one keyword found in the word document then it prints out stuff to excel sheet and transfers to zip folder if that directory was set in the sheet
If WordsFound.Count > 0 Then
'outputting the results
With Worksheets("Results")
.Range("A" & PrintRow).Value = File.Name
'This will merge the words found to one cell
For Each Word In WordsFound
.Range("B" & PrintRow).Value = Word & "/" & .Range("B" & PrintRow).Value
Next
.Hyperlinks.Add Anchor:=.Range("C" & PrintRow), Address:=PathName, TextToDisplay:="Link - Click Here"
'Check if interface wants you to embed file.. Problem is this doesnt seem to allow saving because excel file will always say corrupt and repair but never works so never gets to save
If Worksheets("Search Interface").Shapes("EmbedCheckBox").ControlFormat.Value = 1 Then
.OLEObjects.Add Filename:=PathName, Link:=False, DisplayAsIcon:=True, Left:=.Range("D" & PrintRow).Left + 30, Top:=.Range("D" & PrintRow).Top + 3, Width:=50, Height:=10
End If
'Send to export folder if directory isnt blank
If Not IsEmpty(Worksheets("Search Interface").Range("D4").Value) Then
FileSystem.CopyFile PathName, Worksheets("Search Interface").Range("D4").Value & "\" & FolderName & "\" & "Row Result - " & (PrintRow - 1) & ".docx", True
End If
End With
PrintRow = PrintRow + 1
End If
WordDoc.Close SaveChanges:=False
Set WordDoc = Nothing
End Select
End If
ContinueLoop:
Next
Exit Sub
ErrorHandler:
'since there was an error it prints out the info to tthe excel sheet what file name was and error info where the keyword stuff should have gone . If keyword stuff was filled out and error tripped after that then it wont delete that info and should keep keywords found instead.
With Worksheets("Results")
.Range("A" & PrintRow).Value = File.Name
If IsEmpty(.Range("B" & PrintRow).Value) Then
.Range("B" & PrintRow).Value = "File triggered error -" & Err.Number & " " & Err.Description & " - VBA Line:" & Erl
ErrorCount = ErrorCount + 1 'I want to only count errors if the matching process was not able to go through
End If
.Hyperlinks.Add Anchor:=.Range("C" & PrintRow), Address:=PathName, TextToDisplay:="Link - Click Here"
End With
PrintRow = PrintRow + 1
If Not WordDoc Is Nothing Then
WordDoc.Close SaveChanges:=False
End If
Set WordDoc = Nothing
'GO to the next file like nothing ever happened!
Resume ContinueLoop
End SubOn Error GoTo ErrorHandler
10 Set WordDoc = WordApp.Documents.Open(Filename:=PathName, ReadOnly:=True)
On Error GoTo 0err.clear.text=word
