Create subfolder and copy file. Filepath is variable

[WalterInOz]

I have a folder which holds 1000s of pictures organised in subfolders, for example:
D:\~AI Database Print Scans\2009\family and
D:\~AI Database Print Scans\2009\holiday

And so forth. In total at the moment 17 main subfolders, each of which hold another 2-3 subfolders.

I am putting together a database to bring pictures together with all sorts of details. I import the picture via hyperlink and complete the various fields. All that works fine but there are a lot of pictures! And it gets confusing to see which ones have already been entered into the database and which ones haven’t.
One solution for this is to copy the pictures that have been “completed” to another folder. I have found a way to do that:

Dim fs As Object
Dim oldPath As String, newPath As String
oldPath = Forms!frmPrintDetails.txtPath1
newPath = "D:\~AI Database Print Scans\Completed_Entries\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile oldPath, newPath
Set fs = Nothing

Works fine, but the problem is that I loose the subfolder structure, it copies all pictures to the same main folder. I’d like to maintain the subfolder structure and add code to create the correct subfolders and next copy the picture. With the different paths I’m lost. I don’t know how to extract the correct path in code. Can someone give me a clue?
I’d also like to either rename or remove the picture once I have completed entry of the details. The problem I have again is that I don’t know how to code for a changing path.

Any help greatly appreciated

 

[namliam]

I use this code to check and create folders:

    Dim fso As New scripting.FileSystemObject
    If Dir(myCurrDir & "Import\MT940_processed\" & Year(rst!min), vbDirectory) = "" Then
        fso.CreateFolder myCurrDir & "Import\MT940_processed\" & Year(rst!min)
    End If
    If Dir(myCurrDir & "Import\MT940_processed\" & Year(rst!min) & "\" & Format(rst!min, "YYYYMM"), vbDirectory) = "" Then
        fso.CreateFolder myCurrDir & "Import\MT940_processed\" & Year(rst!min) & "\" & Format(rst!min, "YYYYMM")
    End If

 

[WalterInOz]

Thanks.
I see what you're doing here but can't get it to work. There are a couple a variables that need to be defined.
I assume the MyCurrDir needs a Dim statement
Don't know what to do with the rst!min, vbDirectory.

Here's what I have now:

Private Sub btnCompleterEntry_Click()
Dim fs As Object
Dim oldPath As String, newPath As String
Dim fso As New Scripting.FileSystemObject
Dim MyCurrDir As String

If Dir(MyCurrDir & "Completed\" & Year(rst!min), vbDirectory) = "" Then
fso.CreateFolder MyCurrDir & "Completed\" & Year(rst!min)
End If
If Dir(MyCurrDir & "Completed\" & Year(rst!min) & "\" & Format(rst!min, "YYYYMM"), vbDirectory) = "" Then
fso.CreateFolder MyCurrDir & "ICompleted\" & Year(rst!min) & "\" & Format(rst!min, "YYYYMM")
End If

oldPath = Forms!frmPrintDetails.txtPath1 '"C:\Documents and Settings\user\My Documents\filename.xls"
newPath = "D:\Completed\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile oldPath, newPath
Set fs = Nothing

End Sub

It stops at rst with the message that the variable isn't defined.
Excuse my ignorance, it's trial and error at this end, not enough theoretical knowledge.
Would you mind elaborating further?

 

[Royce]

Instead of moving the files, save a link to the files. I prefer to use a parameter that points to the head of the folder structure, and save only the subfolder\image01.jpg (or .bmp, etc.) in the field.

Below is a process that I use to read a folder and add a record for every new file in the file tree. It takes awhile, especially, when if I have to traverse all 60,000 + images. Ignore the Exiv stuff. That's reading the metadata from the image.

Private Sub ProcessImages(strSourcePath As String)
    '   This calls itself recursively to process all files in the source folder
    ' and all subfolders.
    Dim strTmp As String
    Dim lngResult As Long
    
    
    ' Following are used in Adding record to Pictures Table
    Dim lngResponse As Long
    Dim db As Database
    Dim rst As DAO.Recordset
    Dim rstImg As DAO.Recordset
    
    Dim lngPictureId As Long
    Dim strPicturePath As String
    Dim strFile As String
    
    ' These variables are used to loop through the directory structure
    Dim fso As FileSystemObject
    Dim Fldr As Folder
    Dim fl As File
    Dim SubFldr As Folder

    Dim clsExiv As clsExiv2MetaData
    Set clsExiv = New clsExiv2MetaData
    
    clsExiv.DeleteTempFiles = True
    
    ' Set up recordset used to append the records
    Set db = CurrentDb()
    Set rst = db.OpenRecordset("Select * from Pictures", dbOpenDynaset, dbAppendOnly)
    strPicturePath = Nz(DLookup("[txtPathToPictures]", "Preferences", "lngPreferenceId = " & PreferenceId), "")
    
    Set fso = CreateObject("Scripting.FileSystemObject") ' Get a File object to query.
    
    If Not fso.FolderExists(strSourcePath) Then
        MsgBox "You must select a source  path." _
            & vbCrLf & "(" & strSourcePath & ")"
        
        Me.txtLog.Value = "Source Path not selected"
    
    Else
                
        Set Fldr = fso.GetFolder(strSourcePath)
        ' Process the files in this folder
        For Each fl In Fldr.Files
             'fl.name is in name.ext format.
            
            ' the call to clsExiv exports the Exiv metadata to file with the extension .xmp     
            lngResult = clsExiv.ExtractMetaData(strSourcePath & "\" & fl.Name)
            If lngResult <> err_WKS_clsExiv2_NoErrors Then
                glngErrCount = glngErrCount + 1
                ' Can be ignored but print a message just in case
                Debug.Print "Error: " & CStr(lngResult) & fl.Name
            Else
               
                strTmp = fl.Name
              
                strFile = Mid(fl.Path, Len(strPicturePath) + 1)
                 ' See if the picture is already stored in the database
                lngPictureId = Nz(DLookup("PictureId", "Pictures", "PhotoText = " & Chr$(34) & strFile & Chr$(34)), 0)
                If lngPictureId = 0 Then
                    ' zero means it is not in the database so add it.
                     glngAddCount = glngAddCount + 1
                    With rst
                        .AddNew
                        !PhotoText = strFile
                                             
                        clsExiv.DeleteTempFiles = True
                        
                        strTmp = strPicturePath & strFile
                        If clsExiv.ExtractMetaData(strPicturePath & strFile) = 0 Then
                            !Caption = clsExiv.Caption
                            !dtmPhotoTaken = clsExiv.DateTaken
                            If Len(clsExiv.Tags) > 254 Then
                                !Tags = Left(clsExiv.Tags, 254)
                                !memPictureComments = clsExiv.Description & "  TagOverflow: " & Mid(clsExiv.Tags, 255)
                            Else
                                !Tags = clsExiv.Tags
                                !memPictureComments = clsExiv.Description
                            End If
                            !PictureLongitude = clsExiv.Longitude
                            !PictureLatitude = clsExiv.Latitude
                            !StarRating = clsExiv.StarRating
                        Else
                            !Tags = "Error reading Exiv data"
                        End If
                                    
                        .Update
                                        
                    End With
                Else
                    ' it's in the database so you could update the Exiv data if you wanted to.
                End If
                
            End If
            
            gCount = gCount + 1
            If (gCount Mod 10) = 0 Then
               Me.txtLog.Value = CStr(gCount) & " files processed, " & CStr(glngAddCount) & " Added, " & CStr(glngErrCount) & " Errors"
               DoEvents
               
            End If
            
        Next
        
        For Each SubFldr In Fldr.SubFolders
            ' this is the recursive call that processes the sub folders.
             ProcessImages strSourcePath & "\" & SubFldr.Name
        Next
        
        
        
       
    End If
     
        
Proc_Exit:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Set db = Nothing
    Set fso = Nothing
    Set Fldr = Nothing
    Set clsExiv = Nothing
    
    Exit Sub
    
    
Proc_Err:
    MsgBox Err.Description
    Resume Proc_Exit
    
End Sub

 

[namliam]

I assume the MyCurrDir needs a Dim statement
Don't know what to do with the rst!min, vbDirectory.

Yes sorry may have been a little to short on the answer...

rst!Min is a date that I extract from a table in my database..... basicaly easiest way to replace it is by Date()

MyCurrdir is a remnance from eons ago when currentproject didnt exist
Currently it is a function that simply only calls
MyCurrdir = currentproject.Path & "\"

So you can either make a simular function or simply replace that in....

Making the total changed code something like:
fso.CreateFolder currentproject.Path & "\Completed\" & Year(Date())

Also to use the filesystemobject you need to add a reference to the database "Microsoft scripting runtime"

 

[WalterInOz]

Thank you for your advice Royce. It is not exactly what I had in mind I think. If I understand correctly I'll still be comparing tables to see which pictures and details I have entered into the DB. What I'm trying to do is to move the completed pics to a new folder and subsequently delete or rename the original file. That way I get a exact overview of which ones still need to processed without any comparison.

If I can't get that to work I might revisit your suggestion.

 

[WalterInOz]

Thanks for that clarification Namliam.

I've been a little bit successful with this, but not there yet. Can you give me a bit more help?
What I have now is this:

Private Sub btnCompletedEntry_Click()
Dim fs As Object
Dim oldPath As String, newPath As String
Dim fso As New Scripting.FileSystemObject
 
    If Dir(myCurrDir & "Completed Entries\" & Year(Date), vbDirectory) = "" Then
        fso.CreateFolder "D:\\Completed Entries\" & Year(Date)
    End If
    
    If Dir(myCurrDir & "Completed Entries\" & Year(Date) & "\" & Format(Date, "YYYYMM"), vbDirectory) = "" Then
        fso.CreateFolder "D:\Completed Entries\" & Year(Date) & "\" & Format(Date, "YYYYMM")
    End If


oldPath = Forms!frmPrintDetails.txtPath1
newPath = "D:\Completed Entries\" & Year(Date) & "\" & Format(Date, "YYYYMM") & "\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile oldPath, newPath
Set fs = Nothing

Me.chkCompleted.Value = 1


End Sub

Public Function myCurrDir() As String
' a little function to get the current directory of the DB.
    myCurrDir = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", -1, vbTextCompare))
End Function

This creates 2 subfolders in the 'Completed Entries' folder: 2014 and 201404 + it copies the picture into the latter. That's the good news.
The bad news is that I can't repeat this action with a second picture, error message is Run-time error 58 - File already exists.
The debug indicates the problem lies here:

   fso.CreateFolder "D:\\Completed Entries\" & Year(Date)

So I guess what I need to do is to include some code to check if the folder(s) already exists and if so continue to copy the picture. Correct?

The second issue though is that I still don't see how I can extract the exact folder and subfolder name from the path to the picture in Forms!frmPrintDetails.txtPath1. txtPath1 id a textfield which holds the exact filepath.

Any suggestions?

Dank voor je hulp.

 

[namliam]

The check if the folder exists is already there, the difference is...
In the check you use mycurrdir, using the database's current folder as the "root"
In your create path you are useing the D:\ as your root, this difference is the problem.

Also you may need to worry about the \\ in one of the paths.

 

[WalterInOz]

Thanks for your feedback. If I understand correctly you suggest to change the code as follows:

Private Sub btnCompletedEntry_Click()
Dim fs As Object
Dim oldPath As String, newPath As String
Dim fso As New Scripting.FileSystemObject


If Dir(myCurrDir & "Completed Entries\" & Year(Date), vbDirectory) = "" Then
fso.CreateFolder myCurrDir & "Completed Entries\" & Year(Date)
End If

If Dir(myCurrDir & "Completed Entries\" & Year(Date) & "\" & Format(Date, "YYYYMM"), vbDirectory) = "" Then
fso.CreateFolder myCurrDir & "Completed Entries\" & Year(Date) & "\" & Format(Date, "YYYYMM")
End If


oldPath = Forms!frmPrintDetails.txtPath1
newPath = myCurrDir & "Completed Entries\" & Year(Date) & "\" & Format(Date, "YYYYMM") & "\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile oldPath, newPath
Set fs = Nothing

Me.chkCompleted.Value = 1


End Sub

Public Function myCurrDir() As String
' a little function to get the current directory of the DB.
myCurrDir = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\", -1, vbTextCompare))
End Function

That doesn't do the trick. I get an error message "Path not found" early on in the code on this line:

fso.CreateFolder myCurrDir & "Completed Entries\" & Year(Date)

I really want the picture to be copied to another folder, not to a subfolder in the one holding the DB, that's why I hard coded the path to the main folder in the previous message.
I'll play around a bit more over this weekend. Suggestions welcome.
Thanks again.

 

[namliam]

well you can hardcode the folder(s) no problem but you have to do so in each place applicable... not only in one place.

Dim fso As New Scripting.FileSystemObject
fso.CreateFolder "D:\test test"

Seems to work just fine for me

Does your folder "Completed Entries" exist? it only works one folder at a time...

 

[WalterInOz]

Thanks for your suggestion Namliam.

Yes, the folder "Completed Entries" exists and files are copied to that location using the code in the first posting. But there is more that needs to happen.

I probably haven’t explained very well what exactly it is that I’m trying to achieve here. It is important that I get this right because at the moment I have about 30 subfolders in the folders within the main folder D:\~AI Database Print Scans, each of these subfolders hold 30-60 pictures with more folders and pictures to follow. I have reorganised my filing in such a way that there are no further subfolders anymore. The generic path to the image files now looks like this: D:\~AI Database Print Scans\variable folder name\image name

I need to enter details + a thumbnail of each picture in the database. The exact location of the image file is recorded in a textfield named txtPath1. This path contains the name of the file and the name of the subfolder in which this file is stored.

When I am entering details of each picture I first import the thumbnail by browsing to the location of the file and importing the path. This is recorded in the txtPath1 field. I subsequently enter the other details in about 10 more fields. When that is done I can move on to the next file and repeat the process, etc etc.

What I need to do is make it easy for me to recognise which images have already been recorded. When I now browse to a folder for the next image I can’t see which ones have been done. It would be a lot easier if I only see the images that still need to be done. My solution to that is to copy an image that has been completed, i.e. details have been recorded, to another folder named "Completed Entries" and subsequently delete that original file. This would save me so much comparing and would completely eliminate accidental double entries.

OK, so the copy bit works. I guess I’ll be able to sort out the delete bit as well using something like Kill OldPath & OldFileName

What I can’t do is to replicate the folder structure in the "Completed Entries" folder. I can of course create them by hand and after each couple of completed entries move the copies images into the correct subfolders but that is not very elegant and leaves room for errors. I think that since the complete path is recorded and accessible in the txtPath1 field it should be possible to extract that info from that path and make sure that the picture is stored in the correct brother/sister folder of the orginal folder. I just don’t know how….. And that’s where I need help.
Hardcoding the many subfolders is not an option, I’d need a button for each subfolder.

My apologies for the lengthy post. I hope I’ve explained it better this time.
I’ve been playing with this fo hours now in the past week but can’t work out how to solve this puzzle.

Any ideas anyone?

 

[namliam]

I would strongly suggest you not store any picture in the database, thumbnail or anything else..... Pictures get converted to BMP and take up "a lot of space"

You can loop folders recursively...
sample from a quick google:
http://www.java2s.com/Code/VBA-Exce...ursiveSearchusingtheFileSystemObjectModel.htm

 

[WalterInOz]

Thanks for the link. The information on this website is possible quite helpful for other things I'm struggling with as well. I still haven't solved my original question but continue to work at it.

I am not saving images to the database, the images are loaded from a link and stored as normal image files in various formats. There's no bloating of the DB.