Need help with Application.FileSearch

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

Code:

---

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"

---

Try:

Code:

---

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:

Code:

---

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:

Code:

---

Public FoundFiles(), Counter

---

needs to be at the top of the code module, with or without the Option Explicit - your choice.

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:

Code:

---

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

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.

Attachment 29415

Quote:

---

Originally Posted by 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.

Attachment 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.

Quote:

---

Originally Posted by scerchio

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.

Quote:

---

Originally Posted by scerchio

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 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.

Quote:

---

Originally Posted by scerchio

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.