HillTJ
To train a dog, first know more than the dog..
- Local time
- Today, 05:44
- Joined
- Apr 1, 2019
- Messages
- 731
Hi, I have the code below that enables me to copy a file to an "Archive" (I know it's spelt wrong in the code). It uses a module called 'BrowseFile' to do the look up of the file path, generates a unique file name & saves the file either in a default location (same as access installation) or a nominated location returned from a "Default" table.
Works really well but I'd like to adapt it to be a Public Module that could be used on multiple forms. Could someone assist me with some direction? Appreciate it. Also any code improvements?
Works really well but I'd like to adapt it to be a Public Module that could be used on multiple forms. Could someone assist me with some direction? Appreciate it. Also any code improvements?
Code:
Option Compare Database
Private Sub Browse_to_Photo_Click()
Dim strFullpath As String
Dim strFolder As String
Dim strFile As String
Dim intPos As Integer
Dim InPath As String
Dim FileName As String
Dim OutFolder As String
Dim OutPath As String
Dim RecordNo As String
Dim FileExt As String
Dim Archieve As String
Dim fsFolder As Object
On Error GoTo ErrorHandler
If (IsNull(Me.[Photo_Link]) Or Me.[Photo_Link] = "") Then 'if output record exists then close routine & exit
strFullpath = BrowseFile ' goes to Routine that selects inpath file
RecordNo = Me!Personel_ID
TheTime = Time 'used to generate a unique file name
LRandomNumber = Int((999 - 100 + 1) * Rnd + 100) 'used to generate a unique file name
If IsNull(DLookup("Item_Value", "TBL_Defaults", "Item_Entity='Photo_Folder'")) Then ' returns outpath from defaults, if null selects application file path instead
Archieve = Application.CurrentProject.Path & "\"
Else
Archieve = DLookup("Item_Value", "TBL_Defaults", "Item_Entity='Photo_Folder'")
End If
Set fsFolder = CreateObject("Scripting.FileSystemObject")
Archieve = Archieve & "\" & Year(Date)
If fsFolder.FolderExists(Archieve) = False Then
fsFolder.CreateFolder (Archieve)
End If
If strFullpath <> "" Then ' get folder and file names
intPos = InStrRev(strFullpath, "\")
strFolder = Left(strFullpath, intPos - 1)
strFile = Mid(strFullpath, intPos + 1)
InPath = strFullpath
End If
If (Len(InPath) > 0 And Len(InPath) <= 70) Then
FileName = Mid(InPath, InStrRev(InPath, "\") + 1) 'get the file name
FileExt = Right(FileName, Len(FileName) - InStrRev(FileName, ".") + 1) ' get the file extension with dot
OutPath = [Archieve] & "\" & "Photo" & RecordNo & Format(Now(), "ddmmyy") & Trim(Str(Hour(TheTime))) & Trim(Str(Minute(TheTime))) & Trim(Str(Second(TheTime))) & Trim(Str(LRandomNumber)) & FileExt
Else
MsgBox "File Path Length Incorrect", vbInformation, "Copy Path Incorrect"
Exit Sub
End If
Me.[Photo_Link] = OutPath 'Populates the filed & Allows the file save position to be relocated"
FileCopy InPath, OutPath
Me.Refresh 'to display the updated field
MsgBox "Copied file to archives " & vbCrLf & InPath & vbCrLf & OutPath
Else
MsgBox "A Photo has Already Been Copied", vbInformation, "Photo Exists-Error"
End If
ExitError:
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 52
MsgBox "Error 52-Cannot Repost", vbOKCancel
Exit Sub
Resume Next
Case 76
MsgBox "Error 76-Check File Path may not exist", vbOKCancel
Exit Sub
Resume Next
Case 2302
MsgBox "Error 2302-Check File Path may not exist", vbOKCancel
Exit Sub
Case Else
Call LogError(Err.Number, Err.Description, "Browse To Photo Archive")
Resume ExitError
End Select
End Sub
Last edited by a moderator: