Excel/With Application.FileSearch doesn't work in 2007
Expert: Tom Ogilvy - 7/9/2009
QuestionQUESTION: I have the following code that I wrote in Excel 2003:
Sub Generate_Drawing()
If Sheet10.Range("AN50") = "Drawing Available" Then _
If Range("AG57").Value = "Your drawing is ready to be generated" Then
Sheet10.Unprotect Password:="$$$"
Dim s As String, i As Integer, d As Object
s = "C:\Images"
Sheet10.Range("C4").Select
For Each d In Sheet10.DrawingObjects
If d.TopLeftCell.Address = "$C$4" Then
d.Delete
End If
Next
With Application.FileSearch
.NewSearch
.LookIn = s
.SearchSubFolders = True
.Filename = "*" & Sheet10.Range("E56") & ".EMF"
.Execute
For i = 1 To .FoundFiles.Count
Sheet10.Pictures.Insert (.FoundFiles(i))
Exit For
Next i
End With
Else
End If
Sheet10.Protect Password:="$$$"
Else
If Sheet10.Range("AN50") = "Drawing Not Available" Then _
Ans = MsgBox("Drawing Not Available", vbCritical)
End If
End Sub
This Macro basically looks for a file name in cell E56 and and searches for that file in C:\Images and then pastes that image into cell C4. The Problem is when I run this in excel 2007, the line 'With Application.FileSearch' is highlighted as an error and the code does not work. I've seen that this application has been removed from 2007. How can I modify this code so that it works the same way in 2007 as it does in 2003? Thanks so much if you can help me out.
ANSWER: Melo,
this article explains what you have said and has a link to Microsoft's recommended solution using the scripting runtime or scripting windows search:
http://support.microsoft.com/kb/920229
Error message when you run a macro to search for a file in an Office 2007 program: "Run-time error 5111"
This article also addresses searching directories and subdirectories.
(just provided as an additional source of information).
http://support.microsoft.com/kb/185601/
HOW TO: Recursively Search Directories by Using FileSystemObject
--
Regards,
Tom Ogilvy
---------- FOLLOW-UP ----------
QUESTION: Thanks for the link. I've tried implementing code using the 'recursively search directories' sample, but am unable to do what I am trying to do, as I am very new to VBA. The sample is far different than what I am trying to achieve. If you could give me some advice on how to modify that code it would really be appreciated. Thanks alot for your help.
ANSWER: Melo,
first, go into the Visual Basic Editor (VBE) and make your project the active project by selecting it in the Project Explorer Window.
then go to Tools=>References in the menu in the VBE and scroll through the list of references until you find the Microsoft Scripting Runtime. Click the checkbox next to it so it is selected.
Now,
Insert a new module and paste this code in (read this response at the allexperts site and copy it from there to avoid word wrap problems in email).
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Sub Generate_Drawing()
Dim ans As Long
If Sheet10.Range("AN50") = "Drawing Available" Then _
If Range("AG57").Value = "Your drawing is ready to be generated" Then
Sheet10.Unprotect Password:="$$$"
Dim s As String, i As Integer, d As Object, v As Variant
Dim sName As String
ReDim v(1 To 100)
s = "C:\Images"
Sheet10.Range("C4").Select
For Each d In Sheet10.DrawingObjects
If d.TopLeftCell.Address = "$C$4" Then
d.Delete
End If
Next
sName = "*" & Sheet10.Range("E56") & ".EMF"
Findfiles s, sName
If Len(Trim(v(1))) > 0 Then
For i = 1 To 100
Sheet10.Pictures.Insert v(i)
Exit For
Next i
Else
MsgBox s & "\" & sName & " not found"
End If
End If
Sheet10.Protect Password:="$$$"
Else
If Sheet10.Range("AN50") = "Drawing Not Available" Then _
ans = MsgBox("Drawing Not Available", vbCritical)
End If
End Sub
Public Sub Findfiles(s As String, sName As String)
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
ReDim v(1 To 500)
sDir = s
sSrchString = sName
lSize = FindFile(sDir, sSrchString, nDirs, nFiles, v)
End Sub
Public Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long, v As Variant) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _
FileName))
nFiles = nFiles + 1
' List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
v(nFiles) = fso.BuildPath(fld.Path, FileName)
FileName = Dir() ' Get next file
DoEvents
Wend
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles, v)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
--
Regards,
Tom Ogilvy
---------- FOLLOW-UP ----------
QUESTION: Thanks so much for your help, the macro does run. However, it doesn't seem to be pulling in any files. A msgbox always appears saying 'C:\Images\Drawing(or whatever the file is called).EMF not found' . Is it reading the directory C:\Images as part of the file name as opposed to just the Drawing.EMF part? I've checked to make sure the file name in E56 is the same as the file name in C:\Images so that doesn't seem to be the problem. Any ideas why this isn't pulling in the picture? I truly apologize for taking so much of your time. Thank you very much sir.
AnswerMelo,
Try this version. Since I can't test with your code, I am at a disadvantage.
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Sub Generate_Drawing()
Dim ans As Long
If Sheet10.Range("AN50") = "Drawing Available" Then _
If Range("AG57").Value = "Your drawing is ready to be generated" Then
Sheet10.Unprotect Password:="$$$"
Dim s As String, i As Integer, d As Object, v As Variant
Dim sName As String
ReDim v(1 To 100)
s = "C:\Images"
Sheet10.Range("C4").Select
For Each d In Sheet10.DrawingObjects
If d.TopLeftCell.Address = "$C$4" Then
d.Delete
End If
Next
sName = "*" & Sheet10.Range("E56") & ".EMF"
Findfiles s, sName, v
If Len(Trim(v(1))) > 0 Then
For i = 1 To 100
Sheet10.Pictures.Insert v(i)
Exit For
Next i
Else
MsgBox s & "\" & sName & " not found"
End If
End If
Sheet10.Protect Password:="$$$"
Else
If Sheet10.Range("AN50") = "Drawing Not Available" Then _
ans = MsgBox("Drawing Not Available", vbCritical)
End If
End Sub
Public Sub Findfiles(s As String, sName As String, v As Variant)
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
sDir = s
sSrchString = sName
lSize = FindFile(sDir, sSrchString, nDirs, nFiles, v)
End Sub
Public Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long, v As Variant) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _
FileName))
nFiles = nFiles + 1
' List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
v(nFiles) = fso.BuildPath(fld.Path, FileName)
FileName = Dir() ' Get next file
DoEvents
Wend
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles, v)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
--
Regards,
Tom Ogilvy