Copy files based on query
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Copy files based on query
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
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
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
Hi Hans
C:\Users\dave.willett\Google Drive\ImagePath\
C:\Users\dave.willett\Google Drive\ImagePath\
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy files based on query
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
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
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?
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?
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy files based on query
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
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
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.
What do you think? and where should fso.FileExits go in the routine?
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
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy files based on query
I don't see how this would help or speed up the code...
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
You might be right, I've just run:
And it returned over 9000 files...
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
Cheers ...
Dave.
Dave.
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
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 :
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.
I can't work that bit out.
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
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
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy files based on query
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
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
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
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy files based on query
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
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
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 .....
![ThumbUp :thumbup:](./images/smilies/thumbup.gif)
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 .....
![HairOut :hairout:](./images/smilies/hairout.gif)
![ThumbUp :thumbup:](./images/smilies/thumbup.gif)
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
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?
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
Cheers ...
Dave.
Dave.
-
- Administrator
- Posts: 78545
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy files based on query
Try this:
Warning: this might well be slower, since each file has to be copied individually.
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
Best wishes,
Hans
Hans
-
- SilverLounger
- Posts: 1728
- Joined: 25 Jan 2010, 08:34
- Location: Stoke on Trent - Staffordshire - England
Re: Copy files based on query
Thanks Hans
I'm getting error: End If without Block If
I'm getting error: End If without Block If
Cheers ...
Dave.
Dave.