locked
Run Time Error 445 with Application.FileSearch RRS feed

  • Question

  • Hi All:

    I am having a problem with a macro that I inherited and now that I have upgraded to Excel 2010 it no longer works.  I did a search and found out teh Filesearch is no longer valid for 2007 and up.  I am not able to fix the code and was hoping some one can give me a hand.

    Thanks in Advance

    T

    Option Explicit
    Dim wkbSource As Workbook
    Dim wksTarget As Worksheet
    Dim currdt, mydir, myfile As String
    Dim i As Integer
    Dim isect, Begin, myRange, myEnd As Range
    Public shrdest, shrnm As String
    Dim shrlen As Integer
    Dim oFSO
    Dim sSourceFile
    Public Function ApplyTemplate()
    'Assuming using current day.
    currdt = Format(Date, "mmddyyyy")
    Application.ScreenUpdating = False
    'This is where the edit output will need to go.
    mydir = "c:\temp\EditResults\"
    'Make sure working with the template file.
    Workbooks(1).Activate
    Worksheets("Template").Activate
    Set wksTarget = ActiveSheet
    'Search for Excel files in that folder above that contain current date.
    With Application.FileSearch
                .LookIn = mydir
                .FileType = msoFileTypeExcelWorkbooks
              ' MsgBox .LookIn
                .SearchSubFolders = False
                .Filename = "Prepay_*" & currdt  '1st place filename is created
                '.Filename = ""  'Testing 8/15/13
              ' MsgBox .Filename
     End With
    'Now open all Excel files that meet the date critera one at a time, paste them into the template, then save a copy of that to the shared.
    'Clear out template between each new file.
       With Application.FileSearch
        If .Execute() > 0 Then
            'MsgBox "There were " & .FoundFiles.Count & _
            '    " file(s) found."
            For i = 1 To .FoundFiles.Count
                myfile = .FoundFiles(i)
               
                Workbooks.Open myfile
                Set wkbSource = ActiveWorkbook
                wkbSource.Sheets(1).Range("a1").Activate
               
                ActiveCell.Name = "Begin"
                
                 
                Range("A1").End(xlToRight).EntireColumn.Name = "LastCol"
                Range("A65536").End(xlUp).EntireRow.Name = "LastRow"
                
                
                Set isect = Application.Intersect(Range("LastRow"), Range("LastCol"))
                Range(isect.Address).Name = "myEnd"
                 Range("Begin", "myEnd").Copy
                
                          
                Workbooks(1).Activate
                Worksheets("Template").Range("I1").PasteSpecial
                Application.CutCopyMode = False
                Range("A2").Select
                
              '************************************************************************************************************
                shrlen = Len(Workbooks(2).Name) - 13
                shrnm = Left(Workbooks(2).Name, shrlen)
                'shrdest = "U:\" & shrnm & "\"    'FOR TESTING PURPOSES.
                
                'CHANGE ALPHACHAR IF NEED TO, BUT NEED TO MAP TO DRIVE THIS WAY OR PATH TOO MANY CHARACTERS!!!
                'if shrnm =
                'Created 8/19/13 - MZ
                If shrnm = "Prepay_Modifier_QK_Apply_Reduction" Then
                    shrdest = "W:\xxxx\xxxxx\"
                Else
                    shrdest = "W:\xxxx\" & shrnm & "\"
                End If
                'MsgBox shrdest          'FOR TESTING TO MAKE SURE PATH CORRECT.
               
                Workbooks(1).SaveCopyAs (shrdest & shrnm & "_" & currdt & ".xls")
                Workbooks(2).Close False
                
                           
               Set oFSO = CreateObject("Scripting.FileSystemObject")
                sSourceFile = myfile
                ' Check if file exists to prevent error
                If oFSO.FileExists(sSourceFile) Then
                    oFSO.DeleteFile sSourceFile
                    End If
                ' Clean Up
                Set oFSO = Nothing
                           
                
                'Now clear out template
                wksTarget.Activate
                Range("I1").Name = "Begin"
                Range("I1").End(xlToRight).EntireColumn.Name = "LastCol"
                Range("I65536").End(xlUp).EntireRow.Name = "LastRow"
                
                Set isect = Application.Intersect(Range("LastRow"), Range("LastCol"))
                Range(isect.Address).Name = "myEnd"
                
               Range("Begin", "myEnd").Select
                Selection.ClearContents
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                Selection.Borders(xlEdgeLeft).LineStyle = xlNone
                Selection.Borders(xlEdgeTop).LineStyle = xlNone
                Selection.Borders(xlEdgeBottom).LineStyle = xlNone
                Selection.Borders(xlEdgeRight).LineStyle = xlNone
                Selection.Borders(xlInsideVertical).LineStyle = xlNone
                Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
                Range("I1").Select
                
                '***********************************************************************************
     
     Call SendInfo  'Email function call
                
                shrnm = ""
                shrdest = ""
                shrlen = 0
                
                ActiveWorkbook.Names("Begin").Delete
                ActiveWorkbook.Names("myEnd").Delete
                ActiveWorkbook.Names("LastRow").Delete
                ActiveWorkbook.Names("LastCol").Delete
                           
            Next i
        Else
            MsgBox "There were no files found. Check to see if current date files are in that folder."
            Exit Function
        End If
    End With
    MsgBox ("Files have been saved in template format to shared drive."), vbOKOnly
    End Function
    Private Sub SendInfo()
    Dim objOutlook As Object 'Late binded Outlook Application
    Dim objMail As Object 'Late binded Outlook MailItem
    Dim Created As Boolean 'To check if Outlook is open
    Dim MsgBody As String 'Body of email
    'This finds Outlook, or opens it if it is not open
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
    Set objOutlook = CreateObject("Outlook.Application")
    Created = True
    If objOutlook Is Nothing Then
    MsgBox "Unable to find Outlook."
    Exit Sub
    End If
    End If
    On Error GoTo 0
    'This creates new email item
    On Error Resume Next
    Set objMail = objOutlook.CreateItem(0)
    If objMail Is Nothing Then
    MsgBox "Unable to create new email."
    If Created Then objOutlook.Quit
    Set objOutlook = Nothing
    Exit Sub
    End If
    On Error GoTo 0
    MsgBody = "Today's file has been saved to the following shared directory:  <<\\Server\xxx\xxx\xxx\xxx\xxx\" & shrnm & ">>" _
                & "                                                                                        " _
                & "Thank you"
    Dim newSubject As String
    'Created 8/19/13 - MZ
    If shrnm = "xxxx" Or shrnm = "xxxx" Or shrnm = "Prepay_Asst_Surg_Zero_Desig" Then
       newSubject = "xxxxx - " & shrnm    '-- TESTING 8/15/13
    ElseIf shrnm = "xxxx" Then  'Added 11/21/13 for xxxxx Edit not turned off by BRC
           newSubject = "xxxx - xxxxx (Option 2 Edit)"
           MsgBody = "Today's file has been saved to the following shared directory:  <<\\server\xxx\xxx\xxx\xxx\FACETS\xxx\" & ">>" _
                     & "                                                                                        " _
                     & "Thank you"
    Else: newSubject = "Facets Option 3 Edits - " & shrnm                                     'This is the subject of the email
    End If
    With objMail
    .Subject = newSubject                                       'This is the subject of the email
    'These are the people who will receive the email
    '.To = "email address go here"                                   'TESTING
    .To = "email address go here"
    .Body = MsgBody                                             'This is the body of the email
    .Send                                                       'This sends the email
    End With
    If Created Then objOutlook.Quit
    Set objMail = Nothing
    Set objOutlook = Nothing
    'Set newSubject = Nothing
    End Sub


    Monday, April 14, 2014 8:05 PM

Answers

  • Download this file and import it into your project
    https://dl.dropboxusercontent.com/u/35239054/FileSearch.cls

    This creates a new class module FileSearch, an example is included in the comments.

    In your macro add the declaration line at the top of your sub
      Dim ApplicationFileSearch as New FileSearch
    and change the lines
      With Application.FileSearch
    to
      With ApplicationFileSearch

    Change the line
      .Filename = "Prepay_*" & currdt
    to
      .Filename = "Prepay_*" & currdt & "*.xls*"

    That's all, your code works are before.

    Andreas.
    • Marked as answer by Colorado Tony Wednesday, April 16, 2014 6:11 PM
    Tuesday, April 15, 2014 10:16 AM

All replies

  • Hello,

     FileSearch is no longer support in Office 2007 and above you would have to use Dir commands.

    -----------------------------------------
     if the reply help you mark it as your answer.
     Free Managed .NET ExcelWordPDF Component(Create, Modify, Convert & Print)
    Tuesday, April 15, 2014 9:19 AM
  • Download this file and import it into your project
    https://dl.dropboxusercontent.com/u/35239054/FileSearch.cls

    This creates a new class module FileSearch, an example is included in the comments.

    In your macro add the declaration line at the top of your sub
      Dim ApplicationFileSearch as New FileSearch
    and change the lines
      With Application.FileSearch
    to
      With ApplicationFileSearch

    Change the line
      .Filename = "Prepay_*" & currdt
    to
      .Filename = "Prepay_*" & currdt & "*.xls*"

    That's all, your code works are before.

    Andreas.
    • Marked as answer by Colorado Tony Wednesday, April 16, 2014 6:11 PM
    Tuesday, April 15, 2014 10:16 AM
  • Awesome, thank you!!!!

    If you can what is a class module file and how does it work with a macro?

    Wednesday, April 16, 2014 6:13 PM
  • If you can what is a class module file and how does it work with a macro?

    A class module an object, same as e.g. Range is an object inside Excel. In the VBA editor press F2 to open the object catalog, then you can see all classes (and other things) that are available.

    For the details, here is a good tutorial:
    http://www.wiseowl.co.uk/blog/s161/online-excel-vba-training.htm

    And near the bottom is an explanation what a class is:
    http://www.wiseowl.co.uk/blog/s237/classes.htm

    Andreas.
    Thursday, April 17, 2014 10:02 AM