Mismatch , Word could not fire event, String Longer than 255 characters Errors and cannot fix them!!

bradyboyy88

Well-known Member
Joined
Feb 25, 2015
Messages
554
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.


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 Sub


module -- 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:

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

bradyboyy88

Well-known Member
Joined
Feb 25, 2015
Messages
554
Using Err I was able to see that the line Set WordDoc = WordApp.Documents.Open(Filename:=File.Path, ReadOnly:=True) is tripping all of those errors. Is there a way around these errors and make the files open?
 

Watch MrExcel Video

Forum statistics

Threads
1,123,088
Messages
5,599,664
Members
414,325
Latest member
kfg1287

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top