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"