Run time Error 1004

[TonyTiger]

Hi Experts:
When I run my macro I receive the error:
Run-tim error 1004
Method 'Open' of object 'workbooks' failed.

---code is below------


Option Explicit
Dim ApplicationFileSearch As New FileSearch
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 = "\\network\share"
'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 ApplicationFileSearch
.LookIn = mydir
.FileType = msoFileTypeExcelWorkbooks
' MsgBox .LookIn
.SearchSubFolders = False
.FileName = "Prepay_*" & currdt & ".xls"
' 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 ApplicationFileSearch
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 = "x:\" & shrnm & "\" 'FOR TESTING PURPOSES.

'CHANGE ALPHACHAR IF NEED TO, BUT NEED TO MAP TO DRIVE THIS WAY OR PATH TOO MANY CHARACTERS!!!
shrdest = "x:\users\" & shrnm & "\"
'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

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: " _
& "" _
& "<<\\network\share" " _
& "Thank you"

With objMail
.Subject = shrnm 'This is the subject of the email
'.To = "group" 'TESTING
'These are the people who will receive the email
'.To = email@email.com



.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

End Sub

 

[healey21]

Which version of MS Office are you using as FileSearch was removed from 2007 onwards. Have you also set your References to use Outlook in the VBA screen?

Tools ---> References ---> Search down the list from Microsoft Outlook XX .Object Library

XX being the version number