Copy files based on query

[D Willett]

Guys ( Merry Christmas ).

Would anyone happen to have a VBA routine to copy files from one folder to another based on a query.

I have a query called "qryAllInProgress" which has a unique field called "JobID".
I have a folder structure called 'ConsoleFiles' which contains many folders each named as the JobID, within that folder are images *.jpg

So the dtructure looks like:

Main folder: 'ConsoleFiles'
Sub folder: '235667'
Folder contains: 235667-001.jpg 235667-002.jpg 235667-003.jpg 235667-004.jpg 235667-005.jpg

Sub folder: '476683'
Folder contains: 476683-001.jpg 476683-002.jpg 476683-003.jpg 476683-004.jpg 476683-005.jpg
And hundreds more folders.

For each record in the query (JobID)I would like the contents of the subfolders to be copied to another folder.

Kind Regards

[HansV]

Hi Dave, where should the files be copied to?

[D Willett]

Hi Hans
C:\Users\dave.willett\Google Drive\ImagePath\

[HansV]

Try this (I obviously haven't been able to test it myself):

Code: Select all

Sub Test()
    Const strSource = "C:\Files\ConsoleFiles\" ' change as needed
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Dim fso As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("qryAllInProgress", dbOpenForwardOnly)
    Do While Not rst.EOF
        fso.CopyFile strSource & rst!JobID & "\*.jpg", strTarget
        rst.MoveNext
    Loop
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
End Sub

[D Willett]

Amazing Hans... works like a dream.

Slight tweak if possible.

If no jpg exists skip over the folder.
Only add new files as this routine will run every 15 minutes from a timer.
Delete files where the JobID is no longer in qryAllinProgress so the destimation folder is not over polulated.

Is this possible?

[HansV]

I will have to work on it.

[D Willett]

Thank you Hans, really appreciate the help.

Cheers

[HansV]

It's not a "slight tweak" but a complete rewrite. This version will be much slower because it has to process each file individually.

Code: Select all

Sub Test()
    Const strSource = "C:\Files\ConsoleFiles\" ' change as needed
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Dim fso As Object
    Dim fldSrc As Object
    Dim fldTrg As Object
    Dim fil As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strName As String
    Dim p As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("qryAllInProgress", dbOpenDynaset)
    Do While Not rst.EOF
        Set fldSrc = fso.GetFolder(strSource & rst!JobID)
        For Each fil In fldSrc.Files
            If fil.DateLastModified > DateAdd("n", -15, Now) Then
                fso.CopyFile fil.Path, strTarget
            End If
        Next fil
        rst.MoveNext
    Loop
    Set fldTrg = fso.GetFolder(strTarget)
    For Each fil In fldTrg.Files
        strName = fil.Name
        p = InStr(strName, "-")
        If p > 0 Then
            strName = Left(strName, p - 1)
            rst.FindFirst "JobID=" & strName
            If rst.NoMatch Then
                fil.Delete
            End If
        End If
    Next fil
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
End Sub

[D Willett]

Sorry about that Hans, I didn't think it was going to be so complicated....but really appreciate it

There could be 160 folders at the very least and each folder could take over 100, 200 images so that would just chunk away forever, probably better to just over write the image instead. I was looking at fso.FolderExists to see if a folder has been created plus fso.FileExists to see if a folder has any images in at all ( Plausible that a folder has been created but no images created 'Yet') along the lines of:

From the 1st code version which is really quick.

Code: Select all

If fso.Folderexists(strSource & rst!JobID) Then
        fso.CopyFile strSource & rst!JobID & "\*.jpg", strTarget
        rst.MoveNext
    End If

What do you think? and where should fso.FileExits go in the routine?

[HansV]

I don't see how this would help or speed up the code...

[D Willett]

You might be right, I've just run:

Code: Select all

    If fso.Folderexists(strSource & rst!JobID) Then
        If folder.files.Count > 1 Then
            fso.CopyFile strSource & rst!JobID & "\*.*", strTarget
            rst.MoveNext
        End If
    End If

And it returned over 9000 files...

[D Willett]

I decided to go with your code Hans with a much smaller query which I'm happy gives me just enough information.

I also had to take into account that each folder holds a text file as a log plus pdf files. Based on that I am using :

Code: Select all

If folder.Files.Count > 1 Then

So if there is a folder with no images there will always be a txt file as the log, this seems to work. Then I look for a file extension, if it is "jpg" then copy the file.
However, in its current form the pdf(s) and text file are copied across too so the fso.GetExentionName doesn't work.

Code: Select all

    Const strSource = "L:\mmpdf\ConsoleFiles\" ' change as needed
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Const PATH = strSource
    Dim fso As Object
    Dim fldSrc As Object
    Dim fldTrg As Object
    Dim fil As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strName As String
    Dim p As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(PATH)
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("qryAllInProgressGallery", dbOpenDynaset)
    Do While Not rst.EOF
    
    
        Set fldSrc = fso.GetFolder(strSource & rst!JobID)
        
        If folder.Files.Count > 1 Then
            For Each fil In fldSrc.Files
            If fso.getExtensionName(fldSrc & rst!JobID & "\.jpg") = "jpg" Then
               'If fil.DateLastModified > DateAdd("n", -15, Now) Then
                    fso.CopyFile fil.PATH, strTarget
                End If
                Else
                End If
            Next fil
            rst.MoveNext
        End If
    Loop
    Set fldTrg = fso.GetFolder(strTarget)
    For Each fil In fldTrg.Files
        strName = fil.Name
        p = InStr(strName, "-")
        If p > 0 Then
            strName = Left(strName, p - 1)
            rst.FindFirst "JobID=" & strName
            If rst.NoMatch Then
                fil.Delete
            End If
        End If
    Next fil
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing

I can't work that bit out.

[HansV]

How about

Code: Select all

Sub Test()
    Const strSource = "L:\mmpdf\ConsoleFiles\" ' change as needed
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Dim fso As Object
    Dim fldSrc As Object
    Dim fldTrg As Object
    Dim fil As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strName As String
    Dim p As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("qryAllInProgressGallery", dbOpenDynaset)
    Do While Not rst.EOF
        Set fldSrc = fso.GetFolder(strSource & rst!JobID)
        If fldSrc.Files.Count > 1 Then
            For Each fil In fldSrc.Files
                If fso.GetExtensionName(fil.Path) = "jpg" Then
                    If fil.DateLastModified > DateAdd("n", -15, Now) Then
                        fso.CopyFile fil.Path, strTarget
                    End If
                End If
            Next fil
            rst.MoveNext
        End If
    Loop
    Set fldTrg = fso.GetFolder(strTarget)
    For Each fil In fldTrg.Files
        strName = fil.Name
        p = InStr(strName, "-")
        If p > 0 Then
            strName = Left(strName, p - 1)
            rst.FindFirst "JobID=" & strName
            If rst.NoMatch Then
                fil.Delete
            End If
        End If
    Next fil
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
End Sub

[D Willett]

Slight modification Hans, I've changed the end routine as I will only run this twice a day instead of every 15 minutes as it will be overkill. I opted to just 'Kill' the files and copy a new set from the query, it just makes sense for my purpose. Just one thing though. For testing purpose I narrowed the query to just one JobID, all seems to work ok and stepping through the code ends and I have my mouse pointer back. However, running the code on the whole JobID's (79) the code runs, files killed, files copied across but the mouse whirly gig doesn't stop and becomes unresponsive, thats my only caveat.

Code: Select all

Sub DeleteFiles()

    On Error Resume Next
    Kill "C:\Users\dave.willett\Google Drive\ImagePath\*.jpg"
    On Error GoTo 0
End Sub


Private Sub Command32_Click()
On Error Resume Next
DeleteFiles

'Sub Test()
    Const strSource = "L:\mmpdf\ConsoleFiles\" ' change as needed
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Dim fso As Object
    Dim fldSrc As Object
    Dim fldTrg As Object
    Dim fil As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strName As String
    Dim p As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("qryAllInProgressGallery", dbOpenDynaset)
    Do While Not rst.EOF
        Set fldSrc = fso.GetFolder(strSource & rst!JobID)
        If fldSrc.Files.Count > 1 Then
            For Each fil In fldSrc.Files
                If fso.GetExtensionName(fil.PATH) = "jpg" Then
                    If fso.FileExists(strTarget & fil.Name) = True Then
                    Else
                        fso.CopyFile fil.PATH, strTarget
                    End If
                End If
            Next fil
            rst.MoveNext
        End If
    Loop
    'Set fldTrg = fso.GetFolder(strTarget)
    'For Each fil In fldTrg.Files
    '    strName = fil.Name
    '    p = InStr(strName, "-")
    '    If p > 0 Then
    '        strName = Left(strName, p - 1)
    '        rst.FindFirst "JobID=" & strName
    '        If rst.NoMatch Then
    '            fil.Delete
    '        End If
    '    End If
    'Next fil
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
'End Sub
End Sub

[HansV]

Try this:

Code: Select all

Sub DeleteFiles()
    On Error Resume Next
    Kill "C:\Users\dave.willett\Google Drive\ImagePath\*.jpg"
End Sub

Private Sub Command32_Click()
    Const strSource = "L:\mmpdf\ConsoleFiles\"
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Dim fso As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset

    DeleteFiles

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("qryAllInProgressGallery", dbOpenDynaset)
    Do While Not rst.EOF
        If fso.FolderExists(strSource & rst!JobID) Then
            fso.CopyFile strSource & rst!JobID & "\*.jpg", strTarget
        End If
        rst.MoveNext
    Loop

    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
End Sub

[D Willett]

Perfect Hans.

5,754 Images copied across in approx 1 minute, I can live with that plus I have my pointer back.

Thank you once again friend for the support and your patience .....

[HansV]

You're welcome! Stay safe and healthy!

[D Willett]

Hi Hans

Would be it too much to ask to make a slight change with the code.
Some image sets are in their hundreds, could the code be changed to count to only return the first ten images and then move onto the next JobID?

Code: Select all

Sub GoogleImages()
On Error Resume Next
If Len(Dir("C:\Users\dave.willett\Google Drive\ImagePath", vbDirectory)) > 0 Then
    Const strSource = "L:\mmpdf\ConsoleFiles\"
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Dim fso As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset

    'DeleteFiles

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("qryAllInProgressGallery", dbOpenDynaset)
    Do While Not rst.EOF
        If fso.FolderExists(strSource & rst!JobID) Then
            fso.CopyFile strSource & rst!JobID & "\*.jpg", strTarget
        End If
        rst.MoveNext
    Loop

    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    Set fso = Nothing
    Else
    End If
    
End Sub

[HansV]

Try this:

Code: Select all

Sub GoogleImages()
    Const strSource = "L:\mmpdf\ConsoleFiles\"
    Const strTarget = "C:\Users\dave.willett\Google Drive\ImagePath\"
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim i As Long

    On Error Resume Next
    If Len(Dir("C:\Users\dave.willett\Google Drive\ImagePath", vbDirectory)) > 0 Then

        Set fso = CreateObject("Scripting.FileSystemObject")
        Set dbs = CurrentDb
        Set rst = dbs.OpenRecordset("qryAllInProgressGallery", dbOpenDynaset)
        Do While Not rst.EOF
            If fso.FolderExists(strSource & rst!JobID) Then
                Set fld = fso.GetFolder(strSource & rst!JobID)
                i = 0
                For Each fil In fld.Files
                    If LCase(Right(fil.Name, 4)) = ".jpg" Then
                        fil.Copy strTarget
                        i = i + 1
                        If i = 10 Then Exit For
                    End If
            End If
            rst.MoveNext
        Loop

        rst.Close
        Set rst = Nothing
        Set dbs = Nothing
        Set fso = Nothing
    End If
End Sub

Warning: this might well be slower, since each file has to be copied individually.

[D Willett]

Thanks Hans

I'm getting error: End If without Block If