Adding Attachments from a Folder

Someone asked us yesterday how to add all of the .jpg files from a folder into an Attachment field in a table. In this case, the individual wanted to add one attachment into a new record in the table. This could be pretty useful, so we thought we would post it more broadly.

This code accepts parameters for the folder name, table name containing the attachment, the name of the attachment field, and two optional arguments. The first optional argument is a pattern that can be used when searching a directory, such as "*.*". The second optional argument is a flag to indicate whether to iterate through subfolders. This argument is False by default. The code uses the FileSystemObject which is required on the machine. We're using it late bound so a reference to the Microsoft Scripting Runtime is not required.

Next, add the following routine to the module.

' -------------------------------------------------------------------------
' Procedure : AddAttachmentsFromFolder
' Purpose   : Adds one record to an attachment field for each file in the
'           : specified folder.
' Arguments : strFolder  - Name of the folder
'           : strTable   - Name of the table containing the attachment field
'           : strField   - Name of the attachment field
'           : strPattern - Search pattern for the directory. Defaults to
'           :              all files (*.*)
'           : fIncludeSubfolders - Include subfolders in the specified folder
'           :              Defaults to False
' Comments  : This routine adds a new record to the table, then one attachment.
'           : It commits the changes and handles all cleanup
' -------------------------------------------------------------------------
Sub AddAttachmentsFromFolder(ByVal strFolder As String, _
                             ByVal strTable As String, _
                             ByVal strField As String, _
                             Optional ByVal strPattern As String = "*.*", _
                             Optional ByVal fIncludeSubfolders As Boolean = False)

    Dim strFile      As String
    Dim lngCount     As Long
    Dim rstParent    As DAO.Recordset2
    Dim rstChild     As DAO.Recordset
    Dim fldAttach    As DAO.Field2    
    Dim objFso       As Object ' Scripting.FileSystemObject
    Dim objFolder    As Object ' Scripting.Folder
    Dim objFile      As Object ' Scripting.File
    Dim objSubFolder As Object ' Scripting.Folder 

    On Error GoTo ErrorHandler

    ' Instantiate the FileSystemObject
    Set objFso = CreateObject("Scripting.FileSystemObject")

    ' fix up the folder
    If (Right(strFolder, 1) <> "\") Then strFolder = strFolder & "\" 

    ' make sure the folder exists
    If (Dir(strFolder, vbDirectory) = "") Then
        MsgBox "The specified folder does not exist: " & strFolder, vbExclamation
        Exit Sub
    End If

    ' get the folder object
    Set objFolder = objFso.GetFolder(strFolder)

    ' open the table containing the attachment field
    Set rstParent = CurrentDb().OpenRecordset(strTable)

    ' get the first file
    strFile = Dir(strFolder & strPattern)

    ' get each file that meets the pattern
    While (Len(strFile) > 0)
        ' add a record to the parent table
        Debug.Print strFolder & strFile
        rstParent.AddNew

        ' get the attachment recordset and FileData field to contain the file
        Set rstChild = rstParent.Fields(strField).Value
        Set fldAttach = rstChild.Fields("FileData")

        ' add the attachment to the attachment field
        rstChild.AddNew
        fldAttach.LoadFromFile strFolder & strFile
        rstChild.Update
        rstParent.Update

        ' get the next file
        strFile = Dir
    Wend

    ' recurse subfolders?
    If (fIncludeSubfolders) Then
        For Each objSubFolder In objFolder.SubFolders
            AddAttachmentsFromFolder objSubFolder.Path, strTable, strField, _
                                     strPattern, fIncludeSubfolders        
        Next
    End If

Cleanup:
    rstParent.Close
    Set rstParent = Nothing
    Exit Sub

ErrorHandler:
    Debug.Print "Error " & Err.Number & " - " & Err.Description
    MsgBox Err.Description & vbCrLf & _
           Err.Number & vbCrLf & _
           Err.Source, VbMsgBoxStyle.vbCritical, "AddAttachmentsFromFolder Failed"
    GoTo Cleanup
End Sub

 

To test the routine, supply the name of a folder, as well as the name of a table and field. Here's a wrapper routine that does this. This example will load all .jpg files in the specified directory into a table called tblMyTable.

Sub TestAddAttachmentsFromFolder()
    Const strRootFolder As String = "<EnterFolderName>"
    AddAttachmentsFromFolder strRootFolder, "tblMyTable", "Attachments", _
        "*.jpg", True
    MsgBox "Done adding files from: " & vbCrLf & strRootFolder, _
        vbInformation, "File Import Process Completed"
End Sub