bradyboyy88
Well-known Member
- Joined
- Feb 25, 2015
- Messages
- 562
So, my code has a sheet which allows you to choose 5 keywords, a folder to search through and all of its subfolders and files all the word documents and opens them and then uses the find function to see if the key words are there. If they are then it prints information about the document and the keywords and creates a hyperlink on another sheet to the document. In addition the user is able to select if they want the files with matches to be saved to a zip file.
This code seems to work great but out of 3000 files over 300 seemed to draw type 13 Type mismatch error, 9105 String is longer than 255 characters, and 6002 Word could not fire the event. My code has 1 module which includes a function to zip the files and then the rest is in the worksheet module. The area where the error seem to really come into play are on the for loop as it cycles through each file. Any help in reducing these types of errors would be great because my research is slowly getting less helpful.
If there is a way to know which line is causing which error would be extremely helpful (tried to print erl but that did nothing). I cannot download any third party tools though.
module -- basically from ron bruins website
This code seems to work great but out of 3000 files over 300 seemed to draw type 13 Type mismatch error, 9105 String is longer than 255 characters, and 6002 Word could not fire the event. My code has 1 module which includes a function to zip the files and then the rest is in the worksheet module. The area where the error seem to really come into play are on the for loop as it cycles through each file. Any help in reducing these types of errors would be great because my research is slowly getting less helpful.
If there is a way to know which line is causing which error would be extremely helpful (tried to print erl but that did nothing). I cannot download any third party tools though.
Code:
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 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
'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
Set FileSystem = Nothing
WordApp.Quit
Set WordApp = Nothing
End Sub
Sub RecursiveFolderSearch(Folder)
Dim SubFolder As Object
Dim File As Object
Dim WordDoc As Object
For Each SubFolder In Folder.SubFolders
SubFolderCount = SubFolderCount + 1
RecursiveFolderSearch SubFolder
Next
For Each File In Folder.Files
'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
Set WordDoc = WordApp.Documents.Open(Filename:=File.Path, 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:=File.Path, 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:=File.Path, 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 File.Path, 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:=File.Path, 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 Submodule -- basically from ron bruins website
Code:
Public FileNameZip
Sub NewZip(sPath)
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function Split97(sStr As Variant, sdelim As String) As Variant
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub Zip_All_Files_in_Folder(SourcePath As String, DestinationPath As String)
Dim FolderName
Dim strDate As String
Dim oApp As Object
FolderName = SourcePath & "\"
'Save these two lines if I want stand alone program
'strDate = Format(Now, " dd-mmm-yy h-mm-ss")
'FileNameZip = DestinationPath & "\" & "SearchFileZip " & strDate & ".zip"
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = _
oApp.Namespace(FolderName).items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "You find the zipfile here: " & FileNameZip
End Sub
Last edited:
