@Minty,
I want to follow your method of storing the file data and creating a master path, please.
Tables:
On click event button for the file picker.
Code:
Private Sub cmd_LocateFile_Click() On Error GoTo Error_Handler
Dim sFile As String
Dim sFolder As String
sFile = FSBrowse("", msoFileDialogFilePicker, "All Files (*.*),*.*")
If sFile <> "" Then
sFolder = Application.CodeProject.path & "\" & sAttachmentFolderName & "\"
'Ensure the Attachment folder exists
If FolderExist(sFolder) = False Then MkDir (sFolder)
'Copy the file to the Attachment folder
If CopyFile(sFile, sFolder & GetFileName(sFile)) = True Then
'Add this new path to our db
Me.FullFileName = sFolder & GetFileName(sFile)
Me.Description = GetFileName(sFile)
Else
'Probably should report something here about the File Copy failing
End If
End If
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\cmd_LocateFile_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
On click event for delete button.
Code:
'Delete the current attachment/record and the attachment file itselfPrivate Sub cmd_RecDel_Click()
On Error GoTo Error_Handler
Dim sFile As String
sFile = Me.FullFileName
'Delete the database record
DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
'If we're here the record was deleted, so let delete the actual file from the server
Kill sFile
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
If Err.Number <> 2501 Then
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\cmd_RecDel_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Sub
On click event for open attachment button.
Code:
'Open the attachmentPrivate Sub cmd_ViewFile_Click()
On Error GoTo Error_Handler
Call ExecuteFile(Me.FullFileName, "Open")
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\cmd_ViewFile_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
Module 1 of 2.
Code:
'***************************************************************************************' Module : mod_ExternalFiles
' Author : CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Copyright : Please note that U.O.S. all the content herein considered to be
' intellectual property (copyrighted material).
' It may not be copied, reused or modified in any way without prior
' authorization from its author(s).
'***************************************************************************************
Option Compare Database
Option Explicit
Private Const sModName = "mod_ExternalFiles" 'Application.VBE.ActiveCodePane.CodeModule
'Source: http://www.pacificdb.com.au/MVP/Code/ExeFile.htm
Public Const SW_HIDE = 0
Public Const SW_MINIMIZE = 6
Public Const SW_RESTORE = 9
Public Const SW_SHOW = 5
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOWNORMAL = 1
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Sub ExecuteFile(sFileName As String, sAction As String)
Dim vReturn As Long
'sAction can be either "Open" or "Print".
If ShellExecute(Access.hWndAccessApp, sAction, sFileName, vbNullString, "", SW_SHOWNORMAL) < 33 Then
DoCmd.Beep
MsgBox "File not found."
End If
End Sub
'FSBrowse (File System Browse) allows the operator to browse for a file/folder.
' strStart specifies where the process should start the browser.
' lngType specifies the MsoFileDialogType to use.
' msoFileDialogOpen 1 Open dialog box.
' msoFileDialogSaveAs 2 Save As dialog box.
' msoFileDialogFilePicker 3 File picker dialog box.
' msoFileDialogFolderPicker 4 Folder picker dialog box.
' strPattern specifies which FileType(s) should be included.
'
' Dim sFile As String
' sFile = FSBrowse("", msoFileDialogFilePicker, "MS Excel,*.XLSX; *.XLSM; *.XLS")
' If sFile <> "" Then Me.txt_FinData_Src = sFile
'***** Requires a Reference to the 'Microsoft Office XX.X Object Library *****
Public Function FSBrowse(Optional strStart As String = "", _
Optional lngType As MsoFileDialogType = _
msoFileDialogFolderPicker, _
Optional strPattern As String = "All Files,*.*" _
) As String
Dim varEntry As Variant
FSBrowse = ""
With Application.FileDialog(dialogType:=lngType)
'Set the title to match the type used from the list
.title = "Browse for "
Select Case lngType
Case msoFileDialogOpen
.title = .title & "File to open"
Case msoFileDialogSaveAs
.title = .title & "File to SaveAs"
Case msoFileDialogFilePicker
.title = .title & "File"
Case msoFileDialogFolderPicker
.title = .title & "Folder"
End Select
If lngType <> msoFileDialogFolderPicker Then
'Reset then add filter patterns separated by tildes (~) where
' multiple extensions are separated by semi-colons (;) and the
' description is separated from them by a comma (,).
' Example strPattern :
' "MS Access,*.ACCDB; *.MDB~MS Excel,*.XLSX; *.XLSM; *.XLS"
Call .Filters.Clear
For Each varEntry In Split(strPattern, "~")
Call .Filters.Add(Description:=Split(varEntry, ",")(0), _
Extensions:=Split(varEntry, ",")(1))
Next varEntry
End If
'Set some default settings
.InitialFileName = strStart
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
'Only return a value from the FileDialog if not cancelled.
If .Show Then FSBrowse = .SelectedItems(1)
End With
End Function
'---------------------------------------------------------------------------------------
' Procedure : FolderExist
' DateTime : 2009-Oct-02 13:51
' Author : CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Test for the existance of a Folder/Directory
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFolder - Full path of the folder to be tested for
'---------------------------------------------------------------------------------------
Function FolderExist(sFolder As String) As Boolean
On Error GoTo Error_Handler
If sFolder = vbNullString Then GoTo Error_Handler_Exit
If Dir(sFolder, vbDirectory) <> vbNullString Then
FolderExist = True
End If
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
If Err.Number <> 52 Then
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\FolderExist" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Function
'---------------------------------------------------------------------------------------
' Procedure : CopyFile
' Author : CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Copy a file
' Overwrites existing copy without prompting
' Cannot copy locked files (currently in use)
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' strSource - Path/Name of the file to be copied
' strDest - Path/Name for copying the file to
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 1 2007-Apr-01 Initial Release
'---------------------------------------------------------------------------------------
Function CopyFile(strSource As String, strDest As String) As Boolean
On Error GoTo CopyFile_Error
FileCopy strSource, strDest
CopyFile = True
Exit Function
CopyFile_Error:
If Err.Number = 0 Then
ElseIf Err.Number = 70 Then
MsgBox "The file is currently in use and therfore is locked and cannot be copied at this" & _
" time. Please ensure that no one is using the file and try again.", vbOKOnly, _
"File Currently in Use"
ElseIf Err.Number = 53 Then
MsgBox "The Source File '" & strSource & "' could not be found. Please validate the" & _
" location and name of the specifed Source File and try again", vbOKOnly, _
"File Currently in Use"
Else
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\CopyFile" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Exit Function
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetFileName
' Author : CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Return the filename from a path\filename input
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sFile - string of a path and filename (ie: "c:\temp\test.xls")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2008-Feb-06 Initial Release
'---------------------------------------------------------------------------------------
Function GetFileName(sFile As String)
On Error GoTo Err_Handler
GetFileName = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
Exit_Err_Handler:
Exit Function
Err_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "\GetFileName" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
GoTo Exit_Err_Handler
End Function
Module 2 of 2.
Code:
'***************************************************************************************' Module : mod_DB_Variables
' Author : CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Copyright : Please note that U.O.S. all the content herein considered to be
' intellectual property (copyrighted material).
' It may not be copied, reused or modified in any way without prior
' authorization from its author(s).
'***************************************************************************************
Option Compare Database
Option Explicit
Private Const sModName = "mod_DB_Variables"
Public Const sAttachmentFolderName = "Attachments"