Need help with Application.FileSearch

[scerchio]

HI all,

I have another request for help on this old thread with the same problem. I am not a VBA coder, but I have messed with code that has been written for me, and I have now run into a hard wall with the Application.FileSearch problem. For years after MS removed this in Office2007, I just maintained an old version (Office 2003) on a computer to be able to run this and generate the output. That is not feasible anymore and I am looking for a permanent fix. I think this is a bit of complex coding, and I could not apply the solutions found in this thread on my own.

The Access database is for the management of photographs of whales. There are many forms that are used to manipulate and use the data. In the particular form in question, you are importing photos and metadata into the database, and you provide two key inputs:

Search directory location - this is folder hierarchy with many subfolders where there are photos of whales, and excel files of the metadata for the photos in each subfolder. The Excel file has a column that indicates whether a specific photo (of 100s in the file and subfolder) and its metadata should be imported into the Excel database.

Photo Directory output location - this is the folder where all of the photos that are selected for input are copied.

Upon executing the process, the code searches through the Search Directory structure for the excel files, when it finds one it searches within the Excel file for the records that need to be input, and whenever it finds one, it copies the photo from the subdirectory to the proper destination folder, and the metadata for the photo into a Table (IDPhotosIMPORT), and does this for each record within the excel file, and then goes on to search for the next excel file.

I tried to the comment out the search function, and just do this individually for each Excel metadata file in each subfolder individually, but could not even figure that out.

I have pasted the compete code for the process below. If anyone sees this and can help, it would be greatly appreciated, and you can contact me directly.

Thanks - Sal


Private Sub Command0_Click()
Dim fsoFileSearch As Office.FileSearch
Dim varFile As Variant
Dim strFileSpec As String
Dim strJpegFileLocation As String
Dim strOriginalFile As String
Dim strNewFile As String
Dim SQL As String
Dim lDateString As String
Dim lDateValue As Date
Dim strFeature As String
Dim lText1 As String
Dim lBoat As String
Dim x As Variant
Dim xPhoto As Integer
Dim xRecord As Integer
Dim fs As Object
Dim oldPath As String, newPath As String
'Search the subdirectories
'For Excel files with the first 2 characters of Excel sheet name are '20'
strFileSpec = "20*.xls"
'THIS LOCATION IS WHERE PHOTOS WILL BE COPIED TO AND IS AN INPUT FIELD FROM THE FORM
strJpegFileLocation = Me![PhotoDir]
'zero indexes
xPhoto = 0
xRecord = 0
' If the input in valid, then process the file search.
If Len(strFileSpec) >= 3 And InStr(strFileSpec, "*.xls") > 0 Then
Set fsoFileSearch = Application.FileSearch
With fsoFileSearch
.NewSearch
'THIS LOCATION IS THE DIR BELOW WHICH THE FILE SEARCH WILL BE CONDUCTED AND IS AN INPUT FIELD FROM THE FORM
.LookIn = Me![SearchDir]
.FileName = strFileSpec
.SearchSubFolders = True
If .Execute() > 0 Then
For Each varFile In .FoundFiles
'varFile
' We need to open the file and search for rows with Yes in column M
Dim rs2 As New ADODB.Recordset
Dim cnn2 As New ADODB.Connection
Dim cmd2 As New ADODB.Command
With cnn2
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & varFile & ";Extended Properties=Excel 8.0;"
.Open
End With
Set cmd2.ActiveConnection = cnn2
cmd2.CommandType = adCmdText
cmd2.CommandText = "SELECT * FROM [XML Metadata$]" ' We could add a Where clause here
rs2.CursorLocation = adUseClient
rs2.CursorType = adOpenStatic
rs2.LockType = adLockReadOnly
rs2.Open cmd2
While Not rs2.EOF
'...Check for fields with indicated species FROM THE FORM in column 8 and yes for import in columns 13
If rs2.Fields(7) = Me![Species] And rs2.Fields(12) = "Yes" Then
strOriginalFile = varFile
'We strip out the name of the Excel file itself
While (Right(strOriginalFile, 1) <> "") And Len(strOriginalFile) > 0
strOriginalFile = Left(strOriginalFile, Len(strOriginalFile) - 1)
Wend
' We add directory Orginal plus file name and jpg suffix
strOriginalFile = strOriginalFile & "Original" & rs2.Fields(0) & ".jpg"
' We create the location to copy to
strNewFile = strJpegFileLocation & "" & rs2.Fields(0) & ".jpg"
'Copy strOriginalFile to a new location
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile strOriginalFile, strNewFile 'This file was an .xls file
Set fs = Nothing
'increment index
xPhoto = xPhoto + 1
'Convert Date field in excel file to a true date
lDateString = rs2.Fields(2)
lDateValue = CDate(lDateString)
'Convert Feature field in Excel file into Database naming protocol
If rs2.Fields(11) = "RDF" Then strFeature = "Right Dorsal Fin"
If rs2.Fields(11) = "LDF" Then strFeature = "Left Dorsal Fin"
If rs2.Fields(11) = "RCH" Then strFeature = "Right Chevron"
If rs2.Fields(11) = "RBL" Then strFeature = "Right Blaze"
If rs2.Fields(11) = "LCH" Then strFeature = "Left Chevron"
If rs2.Fields(11) = "TF" Then strFeature = "Tail Flukes"
lText1 = varFile
x = Split(lText1, "")
If Left(x(UBound(x) - 1), 4) = "Card" Then
lBoat = x(UBound(x) - 2)
Else
lBoat = x(UBound(x) - 1)
End If
' To turn warnings off
DoCmd.SetWarnings False
SQL = "INSERT INTO IDPhotosIMPORT (Project_code, Boat, Film_type, Date_of_capture, Photo_location, Frame, _
Raw_image_format, Roll, Photographer, Species, Individual_designation, Matching_designation, Photo_Comment, Feature) Values (""" & Me![ProjectCode] _
& """, """ & lBoat & """, """ & Me![FilmType] & """, #" & lDateValue & "#, """ & Me![Year] & "\photographic\thumbnail" & rs2.Fields(0) _
& ".jpg" & """, """ & Right(rs2.Fields(0), 3) & """, """ & rs2.Fields(1) & """, """ & rs2.Fields(4) & """, """ & rs2.Fields(5) _
& """, """ & rs2.Fields(7) & """, """ & rs2.Fields(9) & """, """ & rs2.Fields(10) & """, """ & rs2.Fields(13) & """, """ & strFeature & """)"
DoCmd.RunSQL SQL
'increment index
xRecord = xRecord + 1
' To turn warnings back on
DoCmd.SetWarnings True
'AFTER MANUALLY CHECKING THE DATA IN THE NEW TABLE, AND ADDING FIELDS THAT ARE CONSTANT FOR IMPORTED DATA,
'WE THEN APPEND TO THE DATABASE TABLE IDPHOTOS MANUALLY
End If
rs2.MoveNext
Wend
cnn2.Close
Next varFile
End If
End With
Else
MsgBox strFileSpec & " is not a valid file specification."
Exit Sub
End If
MsgBox "Import of " & xPhoto & " Photos and " & xRecord & " Records completed"

[p45cal]

Try:
Private Sub Command0_Click()
Dim varFile As Variant
Dim strFileSpec As String
Dim strJpegFileLocation As String
Dim strOriginalFile As String
Dim strNewFile As String
Dim SQL As String
Dim lDateString As String
Dim lDateValue As Date
Dim strFeature As String
Dim lText1 As String
Dim lBoat As String
Dim x As Variant
Dim xPhoto As Integer
Dim xRecord As Integer
Dim fs As Object
'Dim oldPath As String, newPath As String
'
Dim FSOLibrary As Object
'Dim FSOFolder As Object
Dim folderName As String
'For Excel files with the first 2 characters of Excel sheet name are '20'
strFileSpec = "20*.xls"
'THIS LOCATION IS WHERE PHOTOS WILL BE COPIED TO AND IS AN INPUT FIELD FROM THE FORM
strJpegFileLocation = Me![PhotoDir]
'zero indexes
xPhoto = 0
xRecord = 0
' If the input in valid, then process the file search.
If Len(strFileSpec) >= 3 And InStr(strFileSpec, "*.xls") > 0 Then
ReDim FoundFiles(1 To 1)
Counter = 0
'Set the folder name to a variable
folderName = "C:\Users\Pascal\Documents" 'Me![SearchDir]
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
LoopAllSubFolders FSOLibrary.GetFolder(folderName), strFileSpec 'this line puts file names and paths into an array FoundFiles.
If Not IsEmpty(FoundFiles(1)) Then
For Each varFile In FoundFiles
'varFile
' We need to open the file and search for rows with Yes in column M
Dim rs2 As New ADODB.Recordset
Dim cnn2 As New ADODB.Connection
Dim cmd2 As New ADODB.Command
With cnn2
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & varFile & ";Extended Properties=Excel 8.0;"
.Open
End With
Set cmd2.ActiveConnection = cnn2
cmd2.CommandType = adCmdText
cmd2.CommandText = "SELECT * FROM [XML Metadata$]" ' We could add a Where clause here
rs2.CursorLocation = adUseClient
rs2.CursorType = adOpenStatic
rs2.LockType = adLockReadOnly
rs2.Open cmd2
While Not rs2.EOF
'...Check for fields with indicated species FROM THE FORM in column 8 and yes for import in columns 13
If rs2.Fields(7) = Me![Species] And rs2.Fields(12) = "Yes" Then
strOriginalFile = varFile
'We strip out the name of the Excel file itself
While (Right(strOriginalFile, 1) <> "") And Len(strOriginalFile) > 0
strOriginalFile = Left(strOriginalFile, Len(strOriginalFile) - 1)
Wend
' We add directory Orginal plus file name and jpg suffix
strOriginalFile = strOriginalFile & "Original" & rs2.Fields(0) & ".jpg"
' We create the location to copy to
strNewFile = strJpegFileLocation & "" & rs2.Fields(0) & ".jpg"
'Copy strOriginalFile to a new location
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile strOriginalFile, strNewFile 'This file was an .xls file
Set fs = Nothing
'increment index
xPhoto = xPhoto + 1
'Convert Date field in excel file to a true date
lDateString = rs2.Fields(2)
lDateValue = CDate(lDateString)
'Convert Feature field in Excel file into Database naming protocol
If rs2.Fields(11) = "RDF" Then strFeature = "Right Dorsal Fin"
If rs2.Fields(11) = "LDF" Then strFeature = "Left Dorsal Fin"
If rs2.Fields(11) = "RCH" Then strFeature = "Right Chevron"
If rs2.Fields(11) = "RBL" Then strFeature = "Right Blaze"
If rs2.Fields(11) = "LCH" Then strFeature = "Left Chevron"
If rs2.Fields(11) = "TF" Then strFeature = "Tail Flukes"
lText1 = varFile
x = Split(lText1, "")
If Left(x(UBound(x) - 1), 4) = "Card" Then
lBoat = x(UBound(x) - 2)
Else
lBoat = x(UBound(x) - 1)
End If
' To turn warnings off
DoCmd.SetWarnings False
SQL = "INSERT INTO IDPhotosIMPORT (Project_code, Boat, Film_type, Date_of_capture, Photo_location, Frame, _
Raw_image_format, Roll, Photographer, Species, Individual_designation, Matching_designation, Photo_Comment, Feature) Values (""" & Me![ProjectCode] _
& """, """ & lBoat & """, """ & Me![FilmType] & """, #" & lDateValue & "#, """ & Me![Year] & "\photographic\thumbnail" & rs2.Fields(0) _
& ".jpg" & """, """ & Right(rs2.Fields(0), 3) & """, """ & rs2.Fields(1) & """, """ & rs2.Fields(4) & """, """ & rs2.Fields(5) _
& """, """ & rs2.Fields(7) & """, """ & rs2.Fields(9) & """, """ & rs2.Fields(10) & """, """ & rs2.Fields(13) & """, """ & strFeature & """)"

DoCmd.RunSQL SQL
'increment index
xRecord = xRecord + 1
' To turn warnings back on
DoCmd.SetWarnings True
'AFTER MANUALLY CHECKING THE DATA IN THE NEW TABLE, AND ADDING FIELDS THAT ARE CONSTANT FOR IMPORTED DATA,
'WE THEN APPEND TO THE DATABASE TABLE IDPHOTOS MANUALLY
End If
rs2.MoveNext
Wend
cnn2.Close
Next varFile
Else
MsgBox strFileSpec & " may not be a valid file specification."
Exit Sub
End If
End If
MsgBox "Import of " & xPhoto & " Photos and " & xRecord & " Records completed"
End Sub

supported by this in a standard code module:
Option Explicit
Public FoundFiles(), Counter

Sub LoopAllSubFolders(FSOFolder As Object, FileSpec)
Dim FSOSubFolder As Object
Dim FSOFile As Object

'For each subfolder call the macro
If FSOFolder.Attributes <> 1046 Then
For Each FSOSubFolder In FSOFolder.subfolders
LoopAllSubFolders FSOSubFolder, FileSpec
Next
For Each FSOFile In FSOFolder.Files
If FSOFile.Name Like FileSpec Then
Counter = Counter + 1
ReDim Preserve FoundFiles(1 To Counter)
FoundFiles(Counter) = FSOFile.Path
End If
Next
End If
End Sub

Your SQL line came up red in the VBE, you'll have to copy|paste your original SQL line.
The:
Public FoundFiles(), Counter needs to be at the top of the code module, with or without the Option Explicit - your choice.

[scerchio]

Hello p45call,

Thank you very much for your response. Having never requested help from a forum like this, I did not know what to expect and did not expect such a quick response.

So, I replaced the Sub Command routine with your code, pasted in the original SQL statement (which appeared to work as it got rid of the red line), and pasted the support code at the top of the module. Upon running it I received the following error:


The expression On Click you entered as the event property setting produced the following error: Constants, fixed-length strings, arrays, user-defined types and Declare statements not allowed as Public members of object modules

*The expression may not result in the name of a macro, the name of a user-defined function, or [Event Procedure]
*There may have been an error evaluating the function, event, or macro


So apparently it did not like the Public FoundFiles(), Counter statement??

I failed to mention that I am using Access 2010 if that makes a difference.

Also, for completeness sake, the original module had at the top the following:


Option Compare Database

Private Sub addRowExample_Click()
Dim SQL As String
Dim lText As String
Dim lInteger As Integer
lText = "234"
lInteger = 99
SQL = "INSERT INTO TableExample ( TableExampleText, TableExampleNumber ) Values (""" & lText & """," & lInteger & ")"
DoCmd.RunSQL SQL
End Sub


I inserted your support code above this, and tried it both (a) maintaining the Option Compare Database statement, and (b) deleting it entirely. No difference.

Thanks again for your help, and apologies for being such a novice with this.

Best - Sal

[p45cal]

You have put the second block of code into its own separate standard code module, that is, not part of the userform's code module?
If so attach a workbook so I can see what's going on, otherwise I'm working blind.

29415

[scerchio]

You have put the second block of code into its own separate standard code module, that is, not part of the userform's code module?
If so attach a workbook so I can see what's going on, otherwise I'm working blind.

29415


Ok, that was my error, I didnt realize I should create a new Module. As I said, I am really unfamiliar with this, so my apologies again. I moved the code to a separate code module, instead of the Userform's code module. Upon running it I received a "Run-time error '76': path not found" message, and debug took me to the line

LoopAllSubFolders FSOLibrary.GetFolder(folderName), strFileSpec

Looking above that is seems that this may have inadvertently been left in:

folderName = "C:\Users\Pascal\Documents" 'Me![SearchDir]

So I removed the path reference to make it

folderName = Me![SearchDir]

in order to point it to the path and directory where I want to search for the excel files (input into the form). This got it past the previous line it got stuck on, but then it stopped with:

"Run-time error '3706': Provider cannot be found. It may not be properly installed"

and debug takes me to

With cnn2
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & varFile & ";Extended Properties=Excel 8.0;"
.Open

getting stuck on .Open


I have tried to upload a simplified version of the .mdb file to this post, but it will not allow me, it seems you can only upload .accdb files? I then tried to transfer everything to a new blank .accdb file, and that seems to create new problems... Starting to get really lost here. Again thanks for the help and sorry for being such a novice.

[p45cal]

folderName = "C:\Users\Pascal\Documents" 'Me![SearchDir]

So I removed the path reference to make it

folderName = Me![SearchDir]
Oops, my fault, I forgot to take that out.




and debug takes me to

With cnn2
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & varFile & ";Extended Properties=Excel 8.0;"
.Open

getting stuck on .OpenI don't know if I can help with this. I confess to not even looking at the code inside the For Each varFile In FoundFiles..Next varFile loop; I just wrote code to give you the same as Application.Filesearch gave. So I'm not sure what that code is doing.
I imagine that the lines that matter will be the likes of:
.Provider = "Microsoft.Jet.OLEDB.4.0"
and
.ConnectionString = "Data Source=" & varFile & ";Extended Properties=Excel 8.0;"
I suspect they'll need updating but I don't know what to, off the top of my head. Jet won't work in 64bit environments, you might be able to make it work with "Microsoft.ACE.OLEDB.12.0"
It looks like it might be adding records to an Access database?
Things that might help are knowing: what version of Excel you're using now, whether you're using 32-bit or 64-bit versions of Excel (and perhaps of Access), what version of Excel files you're interrogating, and maybe even your operating system bitness!
The code is only bringing in .xls files; now if you're updating perhaps you need to be looking at .xlsx, .xlsb and .xlsm files too? Perhaps strFileSpec = "20*.xls*" might take care of that part.

Another thing that might need looking at is the references in the VBE; go to the vb editor and at the top choose Tools, then References. Is anything marked a MISSING? Do you have a reference to Microsoft ActiveX DataObjects n.n Library?

How did you get the macro? Did you record your doing something in Excel and tweak it? If you still know the person who wrote the code, could you ask them to update this part?

You may find https://www.connectionstrings.com useful, but don't go ahead and install some driver or other, you've probably already got everything you need on your machine.



I have tried to upload a simplified version of the .mdb file to this post, but it will not allow me, it seems you can only upload .accdb files? I then tried to transfer everything to a new blank .accdb file, and that seems to create new problems... Starting to get really lost here.I think if you zip the files you'll be able to upload.