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.
Click upload button to browse for single file (.pdf)
Select file then click Ok on file browser
Once the Submit Button is clicked
Directories created on server
Creates next directory using the Year from "Inspected Date" field
Creates next directory "TCRA"
Creates next directory using "Level" field
Creates next directory using "Block" field
Example Directory Path: G:\2022\TCRA\09L\R60
File copied & renamed
Renames file as follows: YEAR-LevelBlock.pdf
Example: 2022-09LR60.pdf
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?
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.
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:
Code:
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:
Code:
Dim sFolder as string
sFolder="G:\" & Year(Me.InspectionDate) & "\" & Me.Level & "\" & Me.Block
If Dir(sfolder,vbDirectory)="" Then MyMkDir(sFolder)
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.
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.
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.
Code:
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
you can simplify your code and just create the folder without checking for it's existence:
Code:
'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
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.
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.
Code:
Private Sub BrowseBtn_Click()
BrowseForFiles False, 1
txtDisplaySelectedFiles = DISPLAYPATH
End Sub
BrowseForFiles
Code:
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
Code:
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
Code:
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
Code:
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
Code:
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.
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.