Upload file, copy & rename dynamically

[KadeFoster]

Hey all,

I am working through my project and have come up to a bit that is a little out of my skill level. Hopefully some one can help. I am working on all my inputs (forms) to make sure I can capture all the data I need from the user before I work on the Reports.

Unfortunately I am learning as I go, because I have to get this up and running before the Excel system that we have dies.

Issue:
I would like to upload a file (.pdf) to this record and have it copied to a directory on my server, and renames with a standardised name.

1. Click upload button to browse for single file (.pdf)
2. Select file then click Ok on file browser
3. Once the Submit Button is clicked
4. Directories created on server
   1. Creates next directory using the Year from "Inspected Date" field
   2. Creates next directory "TCRA"
   3. Creates next directory using "Level" field
   4. Creates next directory using "Block" field
      
      Example Directory Path: G:\2022\TCRA\09L\R60
5. File copied & renamed
   1. Renames file as follows: YEAR-LevelBlock.pdf
      Example: 2022-09LR60.pdf
6. Have the file linked to the TCRAID via a hyperlink or what ever.

What buttons and fields would I need to create to go with this setup?

Cheers

 

[pbaldy]

I'll get you started. Look at FileDialog for the browse, MkDir for creating directories, FileCopy for copying/renaming.

 

[Sodslaw]

starting point... try this to create the pdf..

strReport='your report
strWhere='the record to print TCRAID?
strFolder='folder path to save
strSubject = #Date(yyyy)# & "-" & Me.TCRA & Me.Level & Me.Block & ".pdf" ' Something like that assuming this will be a unique name, ideally the TCRA ID
DoCmd.OpenReport strReport, acViewPreview, , strWhere 'if you want to preview, specify strReport & strWhere
DoCmd.OutputTo acOutputReport, strReport, acFormatPDF, strFolder & strSubject 'creates the PDF,specify strReport,strfolder & strSubject.

 

[bastanu]

Here is come code that will help (in case you need to create UNC paths as MkDIr doesn't support those). Copy into a standard module:

Option Compare Database

Option Explicit
Const FO_COPY = &H2
Const FO_DELETE = &H3
Const FO_MOVE = &H1
Const FO_RENAME = &H4
Const FOF_ALLOWUNDO = &H40
Const FOF_SILENT = &H4
Const FOF_NOCONFIRMATION = &H10
Const FOF_RENAMEONCOLLISION = &H8
Const FOF_NOCONFIRMMKDIR = &H200
Const FOF_FILESONLY = &H80


Private Type SHFILEOPSTRUCT
    hwnd      As LongPtr
    wFunc     As LongPtr
    pFrom     As String
    pTo       As String
    fFlags    As Integer
    fAborted  As Boolean
    hNameMaps As LongPtr
    sProgress As String
End Type
    
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" _
  Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPtr

    
Public Function fnCopyFIle(sSource As String, sDest As String)
Dim lFileOp  As LongPtr
Dim lresult  As LongPtr
Dim lFlags   As Long
Dim SHFileOp As SHFILEOPSTRUCT
lFileOp = FO_COPY
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_SILENT
With SHFileOp
    .wFunc = lFileOp
    .pFrom = sSource & vbNullChar & vbNullChar
    .pTo = sDest & vbNullChar & vbNullChar
    .fFlags = lFlags
End With
lresult = SHFileOperation(SHFileOp)

End Function


Public Sub MyMkDir(sPath As String)
    Dim iStart          As Integer
    Dim aDirs           As Variant
    Dim sCurDir         As String
    Dim i               As Integer
 
    If sPath <> "" Then
        aDirs = Split(sPath, "\")
        If Left(sPath, 2) = "\\" Then
            iStart = 3
        Else
            iStart = 1
        End If
 
        sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
 
        For i = iStart To UBound(aDirs)
            sCurDir = sCurDir & aDirs(i) & "\"
            If Dir(sCurDir, vbDirectory) = vbNullString Then
                MkDir sCurDir
            End If
        Next i
    End If
End Sub

You can check if the directory exists:

Dim sFolder as string

sFolder="G:\" & Year(Me.InspectionDate) & "\" & Me.Level & "\" & Me.Block

If Dir(sfolder,vbDirectory)="" Then MyMkDir(sFolder)

You just need to browse for the file and copy it.

Cheers,

 

[KadeFoster]

OK thanks for all your help, yep totally think this is above my head for the time being. But I am continuing to research and try to understand what you all have shared with me.

 

[The_Doc_Man]

I would like to upload a file (.pdf) to this record and have it copied to a directory on my server, and renames with a standardised name.

First and foremost question: Regardless of where you want to put it, where it it before you get it?

a. Somewhere on a computer within your current network domain that you see with Windows Explorer and thus do a drag-n-drop copy if you were doing it by hand.

b. Somewhere out in the Internet (even though a cooperative site) that requires use of FTP or HTTP to do the upload.

Everything else you wanted to do is actually not that hard... but option (b) above would be a LOT trickier. Option (a) is not that hard.

If you look up the FileSystemObject, everything else you wanted to do can be done from that one facility. It can do file copies, created new folders, and rename already-existing files. It is part of the Windows "Scripting" library and it gives you handles on all of the basic commands you can do from Windows Explorer's right-click quick menu - plus a few things besides that.

 

[KadeFoster]

I have beginner VBA skills, so i am going to break down what i do into little sections and learn as i go. I have created a module for checking if the folders exist and then makes them if they aren't.

Its pretty basic but it works. Not sure if it will be an issue when i split my database. Suggestions welcome. I'll be working on the Dialog box and moving part now.

Private Sub CreateDirs()

'' Add Microsoft Office Object Library in References
'' Add Microsoft Scripting Runtime in References
'
On Error GoTo SubError

    Dim FSO As FileSystemObject
    Dim newPath As String
    Dim subFolder1 As String
    Dim subFolder2 As String
    Dim subFolder3 As String
    Dim tcraFolder As String
    Dim inspFolder As String
    Dim reqFolder As String
    Dim compFolder As String
    Dim testPath As String

    Set FSO = New FileSystemObject
   
    subFolder1 = Year(Date)
    subFolder2 = "09L"
    subFolder3 = "N73"
    tcraFolder = "TCRA"
    inspFolder = "INSPECTIONS"
    reqFolder = "REQUESTS"
    compFolder = "COMPLETED"
       
    newPath = FSO.buildPath(Application.CurrentProject.Path, subFolder1 & "\" & subFolder2 & "\" & subFolder3)
    testPath = FSO.buildPath(Application.CurrentProject.Path, subFolder1)
   
    Do Until FSO.FolderExists(newPath)
        Do Until FSO.FolderExists(testPath)
            FSO.CreateFolder (testPath)
        Loop
        testPath = FSO.buildPath(Application.CurrentProject.Path, subFolder1 & "\" & subFolder2)
        Do Until FSO.FolderExists(testPath)
            FSO.CreateFolder (testPath)
        Loop
        testPath = FSO.buildPath(Application.CurrentProject.Path, subFolder1 & "\" & subFolder2 & "\" & subFolder3)
        Do Until FSO.FolderExists(testPath)
            FSO.CreateFolder (testPath)
        Loop
        testPath = FSO.buildPath(Application.CurrentProject.Path, subFolder1 & "\" & subFolder2 & "\" & subFolder3)
    Loop

Subexit:
'On Error Resume Next
    Exit Sub

SubError:
    MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, "An Error has occured. "
    GoTo Subexit
   
End Sub

'Folder Structure For Storing Files
'EXAMPLE: Project\2022\09L\N73\TCRA
'EXAMPLE: Project\2022\09L\N73\INSPECTIONS
'EXAMPLE: Project\2022\09L\N73\REQUESTS
'
'
'Project Root
'    Year
'        Level
'            BLOCK
'                TCRA - TCRA inspection maps
'                INSPECTION - Any maps / images uploaded to an inspection request
'                REQUESTS - Any maps / images that are to jobs requested not from TCRA

 

[arnelgp]

you can simplify your code and just create the folder without checking for it's existence:

'arnelgp
'put this Function in separate module
Public Function forceMKDir(ByVal sPath As String)
    Dim v As Variant
    Dim s As String
    Dim i As Integer
    v = Split(sPath, "\")
    On Error Resume Next
    For i = 0 To UBound(v)
        s = s & v(i)
        VBA.MkDir s
        s = s & "\"
    Next
End Function


Private Sub CreateDirs()

'' Add Microsoft Office Object Library in References
'' Add Microsoft Scripting Runtime in References
'
On Error GoTo SubError

    Dim FSO As FileSystemObject
    Dim newPath As String
    Dim subFolder1 As String
    Dim subFolder2 As String
    Dim subFolder3 As String
    'Dim tcraFolder As String
    'Dim inspFolder As String
    'Dim reqFolder As String
    'Dim compFolder As String
    'Dim testPath As String

    'arnelgp
    Dim subFolders(1 To 4) As String
    Dim i As Integer
    
    subFolders(1) = "TCRA"
    subFolders(2) = "INSPECTIONS"
    subFolders(3) = "REQUESTS"
    subFolders(4) = "COMPLETED"
    
    Set FSO = New FileSystemObject
  
    subFolder1 = Year(Date)
    subFolder2 = "09L"
    subFolder3 = "N73"
    
    'force create the folders if it does not exists
    
    For i = 1 To 4
        newPath = Application.CurrentProject.path & subFolder1 & "\" & subFolder2 & "\" & subFolder3 & "\" & subFolders(i)
        'if the folder/subfolder already exists, you'll get error but the erro will be ignored.
        Call forceMKDir(newPath)
    Next
    
    'tcraFolder = "TCRA"
    'inspFolder = "INSPECTIONS"
    'reqFolder = "REQUESTS"
    'compFolder = "COMPLETED"
      
    'newPath = FSO.BuildPath(Application.CurrentProject.path, subFolder1 & "\" & subFolder2 & "\" & subFolder3)
    'testPath = FSO.BuildPath(Application.CurrentProject.path, subFolder1)
  '
    'Do Until FSO.FolderExists(newPath)
    '    Do Until FSO.FolderExists(testPath)
    '        FSO.CreateFolder (testPath)
    '    Loop
    '    testPath = FSO.BuildPath(Application.CurrentProject.path, subFolder1 & "\" & subFolder2)
    '    Do Until FSO.FolderExists(testPath)
    '        FSO.CreateFolder (testPath)
    '    Loop
    '    testPath = FSO.BuildPath(Application.CurrentProject.path, subFolder1 & "\" & subFolder2 & "\" & subFolder3)
    '    Do Until FSO.FolderExists(testPath)
    '        FSO.CreateFolder (testPath)
    '    Loop
    '    testPath = FSO.BuildPath(Application.CurrentProject.path, subFolder1 & "\" & subFolder2 & "\" & subFolder3)
    'Loop

Subexit:
'On Error Resume Next
    Exit Sub

SubError:
    MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, "An Error has occured. "
    GoTo Subexit
  
End Sub

'Folder Structure For Storing Files
'EXAMPLE: Project\2022\09L\N73\TCRA
'EXAMPLE: Project\2022\09L\N73\INSPECTIONS
'EXAMPLE: Project\2022\09L\N73\REQUESTS
'
'
'Project Root
'    Year
'        Level
'            BLOCK
'                TCRA - TCRA inspection maps
'                INSPECTION - Any maps / images uploaded to an inspection request
'                REQUESTS - Any maps / images that are to jobs requested not from TCRA

 

[KadeFoster]

Would it just overwrite the folder without any issues?

 

[arnelgp]

Would it just overwrite the folder without any issues?

it will not overwrite the folder or re-create the folder or delete the content of the folder.
test it by creating a "dummy" folder and add files to it.
run the function to create the folder.

 

[KadeFoster]

ok i have come up with a solution that works.
I have 3 Public Variables declared on my Global Module.

Public NEWPATH As String
Public UPLOADPATHS As Collection
Public DISPLAYPATH As String

And have made the separate parts of my solution into modules.

Ok so first part. Browse Button.

Private Sub BrowseBtn_Click()

    BrowseForFiles False, 1
    txtDisplaySelectedFiles = DISPLAYPATH

End Sub

BrowseForFiles

Public Sub BrowseForFiles(MultiSelect As Boolean, FilterChoice As Integer)
    
    On Error GoTo SubError
    'Add Microsoft Office Object Library in Reference
    
    Dim fDialog As Office.FileDialog
    Dim varFile As Variant
    Dim DesktopPath As String
    
    DesktopPath = Environ("UserProfile") & "\Desktop\"
    'find out where user's desktop is
    
    DISPLAYPATH = "" 'Public Variable String
      
    'Setup the File Dialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    
    With fDialog
        
        If FilterChoice = 1 Then .Title = "Choose a .PDF to upload"
        If FilterChoice = 2 Then .Title = "Choose a file or multiple files upload.  Hold [Ctrl] button and select each file."
        
        .AllowMultiSelect = MultiSelect 'Selection passed into sub MultiSelect
        .InitialFileName = "D:\tyrel\OneDrive\Desktop\Testfolder\" ' Folder picker needs trailing slash
        '.InitialFileName = DesktopPath
        .Filters.Clear
        
        If FilterChoice = 1 Then .Filters.Add "*.PDF", "*.pdf"
        If FilterChoice = 2 Then .Filters.Add "Files", "*.pdf, *.jpg, *.jpeg, *.png, *.bmp"
        
        If .Show = True Then
            If .SelectedItems.Count = 0 Then
                'user clicked open but didn't select a file
                GoTo Subexit
            End If
            
            Dim colUploadFiles As New Collection
            
            'Displays the path for multiple files in the txt field, 1 per line
            For Each varFile In .SelectedItems
                DISPLAYPATH = DISPLAYPATH & varFile & vbCrLf
                colUploadFiles.Add varFile
            Next
        Else
            'user cancelled dialog without choosing file
            'do you need to react?
        End If
        
    End With
    PopulateColl colUploadFiles
    
Subexit:
On Error Resume Next
    Set fDialog = Nothing
    Exit Sub
    
SubError:
    MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
        "An error occurred"
                    
    GoTo Subexit

End Sub

Next I have the rest on the Submit button click

Private Sub SubmitBtn_Click()
    
    DoCmd.Save
    
    CreateDirs LevelDisplay, BlockDisplay, 2 '2 For INSPECTION
    CopyRename LevelDisplay, BlockDisplay, 2 '2 For INSPECTION

    DoCmd.Close acForm, "TCRAInspectionF"

End Sub

Create directories

Public Sub CreateDirs(ByVal subFolder2, subFolder3 As String, sourceFolder As Integer)

'' After click event of submit button
'' Add Microsoft Office Object Library in References
'' Add Microsoft Scripting Runtime in References
'
On Error GoTo SubError

    Dim fso As FileSystemObject
    Dim subYearFolder As String
    Dim subFolder4 As String
    Dim testPath As String
    
    Set fso = New FileSystemObject
    
    subYearFolder = Year(Date)
    
    If sourceFolder = 1 Then subFolder4 = "TCRA"
    If sourceFolder = 2 Then subFolder4 = "INSPECTIONS"
    If sourceFolder = 3 Then subFolder4 = "REQUESTS"
    If sourceFolder = 4 Then subFolder4 = "COMPLETED"
      
    'Sets the Names up
    NEWPATH = fso.buildPath(Application.CurrentProject.Path, subYearFolder & "\" & subFolder2 & "\" & subFolder3 & "\" & subFolder4)
    testPath = fso.buildPath(Application.CurrentProject.Path, subYearFolder)
    
    Do Until fso.FolderExists(NEWPATH)
        Do Until fso.FolderExists(testPath)
            fso.CreateFolder (testPath)
        Loop
        testPath = fso.buildPath(Application.CurrentProject.Path, subYearFolder & "\" & subFolder2)
        Do Until fso.FolderExists(testPath)
            fso.CreateFolder (testPath)
        Loop
        testPath = fso.buildPath(Application.CurrentProject.Path, subYearFolder & "\" & subFolder2 & "\" & subFolder3)
        Do Until fso.FolderExists(testPath)
            fso.CreateFolder (testPath)
        Loop
        testPath = fso.buildPath(Application.CurrentProject.Path, subYearFolder & "\" & subFolder2 & "\" & subFolder3 & "\" & subFolder4)
        Do Until fso.FolderExists(testPath)
            fso.CreateFolder (testPath)
        Loop
        testPath = fso.buildPath(Application.CurrentProject.Path, subYearFolder & "\" & subFolder2 & "\" & subFolder3 & "\" & subFolder4)
    Loop

    Set fso = Nothing
    
Subexit:
On Error Resume Next
    Exit Sub

SubError:
    MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, "An Error has occured"
    GoTo Subexit

End Sub

CopyRename

Public Sub CopyRename(ByVal strLevel As String, strBlock As String, intType As Integer)
'Sub copies selected files from path1 to path2 and renames them

    Dim fso As FileSystemObject
    Dim fileToCopy As String
    Dim strBaseName As String
    Dim strNewBaseName As String
    Dim strExtension As String
    Dim strCounter As String
    Dim strSource As String
    Dim varFile As Variant
    
    Set fso = New FileSystemObject
    
'    For Each varFile In UPLOADPATHS
'        Debug.Print varFile
'    Next varFile
    
    If intType = 1 Then strSource = "TCRA"
    If intType = 2 Then strSource = "INSP"
    If intType = 3 Then strSource = "REQU"
    If intType = 4 Then strSource = "COMP"
    
    For Each varFile In UPLOADPATHS
        fileToCopy = varFile
        
        'Sets the Names up
        strCounter = "0"
        strCounter = Format(strCounter, "00")
        strBaseName = strSource & Format(Now(), "yymmdd") & strLevel & strBlock
        strNewBaseName = strSource & Format(Now(), "yymmdd") & strLevel & strBlock & strCounter
        strExtension = fso.GetExtensionName(fileToCopy)
    
        'Checks if file exists and if it does appends a counter to the name
        'For Each fileToCopy In .SelectedItems
        Do Until Not fso.FileExists(NEWPATH & "\" & strNewBaseName & "." & strExtension)
            strCounter = strCounter + 1
            strCounter = Format(strCounter, "00")
            strNewBaseName = strBaseName & strCounter
        Loop
            
        'Copies the file from path1 to path2
        fso.CopyFile fileToCopy, NEWPATH & "\" & strNewBaseName & "." & strExtension, False
    Next varFile
    
    Set fso = Nothing
    NEWPATH = ""
    
Subexit:
On Error Resume Next
    Exit Sub

End Sub

And I created a sub to set up my collection

Public Sub PopulateColl(ByVal coll As Collection)
'Populates a public Collection "UPLOADPATHS"
    
    Set UPLOADPATHS = coll

End Sub

I ran into issues when i was passing the Paths into the Copy procedure from the Display control on the form. A single file was fine, but when I tried multiple files and added the vbCrLf to each entry I kept getting errors. When I went into the Display control after I had had selected a single file (when multi was True) and pressed Backspace once the Copy procedure would work. It was passing in a space at the end of my string which i could not remove no matter what I tried. So i just created a collection to pass in.

Not sure if this helps any one or you would prefer to see my actual project. Let me know.

..... now to get it to add entries to the correct tables for each file path.

 

[KadeFoster]

Well i was going to upload my project file but its says" its too big". It is only 10megs hmmm

 

[pbaldy]

Try doing a compact/repair and then zipping.

 

[KadeFoster]

Ok cool well that compressed down well. I hope that i am going the right way with my project. Its hard to know when you don't know what your doing. I want it to do things so then i work out how to do that, then move onto the next part.

 

[pbaldy]

Do you have an issue to resolve or were you just posting the app to help others here?

 

[KadeFoster]

Do you have an issue to resolve or were you just posting the app to help others here?

Was just posting my solution. Not sure how helpful it will be. Maybe some one could use what i made.

 

[pbaldy]

Maybe some one could use what i made.

It absolutely could help someone, thanks for posting it! I just didn't know if you still needed help with something.

 

[KadeFoster]

I think i got that part sorted, code does what i outlined at the start.