Consulting

Results 1 to 6 of 6

Thread: Need help with Application.FileSearch

  1. #1
    VBAX Newbie
    Joined
    Feb 2022
    Posts
    3
    Location

    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

    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"

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    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.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  3. #3
    VBAX Newbie
    Joined
    Feb 2022
    Posts
    3
    Location
    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
    Last edited by Aussiebear; 02-16-2022 at 01:50 PM. Reason: Added code tags to supplied code

  4. #4
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    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.

    2022-02-16_205114.jpg
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  5. #5
    VBAX Newbie
    Joined
    Feb 2022
    Posts
    3
    Location
    Quote Originally Posted by p45cal View Post
    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.

    2022-02-16_205114.jpg

    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.

  6. #6
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Quote Originally Posted by scerchio View Post
    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 View Post
    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 View Post
    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.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •