Adding multiple attachments from a folder

' -------------------------------------------------------------------------
' Procedure : StoreFilesInTable
' Purpose   : Adds all files matching the specified file mask from the
'           : specified folder to an attachment field.
'           : Each row in the represents all files stored from the folder.
' Arguments : strFolder - The path to the folder stored in the attachment field.
'           : strTable  - The name of the table containing the attachment field.
'           : strPathField - The name of the field for the archived folder.
'           : strAttachmentField - The name of the attachment field. [Files]
'           : strPattern - File mask. [*.*]
'           : blnIncludeSubfolders - Recurse into subfolders. [False]
'           : db1 - The database to operate on.  [CurrentDb]
' Comments  : The db1 param is included so this can be used to store files in
'           : a separate database, since using the attachment field this way
'           : can quickly push a database beyond the 2gb file size limit.
' -------------------------------------------------------------------------
Public Function StoreFilesInTable( _
                ByVal strFolder As String, _
                ByVal strTable As String, _
                ByVal strPathField As String, _
                Optional ByVal strAttachmentField As String = "Files", _
                Optional ByVal strPattern As String = "*.*", _
                Optional ByVal blnIncludeSubfolders As Boolean = False, _
                Optional ByRef db1 As DAO.Database)

    Const CALLER = "StoreFilesInTable"
    On Error GoTo StoreFilesInTable_ErrorHandler

    Dim strFilePath As String
    Dim rstParent   As DAO.Recordset2
    Dim rstChild    As DAO.Recordset2
    Dim fldAttach   As DAO.Field2

    ' These objects require a reference to the "Microsoft Scripting Runtime"
    ' but are defined as "Object" instead to use late binding and avoid that.
    ' If you've added the reference, remove the "Object" and uncomment the
    ' following lines to get the intellisense autocomplete for these objects.
    Dim objFso       As Object ' Scripting.FileSystemObject
    Dim objFolder    As Object ' Scripting.Folder
    Dim objSubFolder As Object ' Scripting.Folder
    Dim objFile      As Object ' Scripting.File

    ' If the user did not specify a database, use the current one.
    If db1 Is Nothing Then Set db1 = Application.CurrentDb

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

    ' Make sure the folder path always ends with a "\".
    If (Right(strFolder, 1) <> "\") Then strFolder = strFolder & "\"

    ' Make sure the folder exists.
    If Not objFso.FolderExists(strFolder) Then
        MsgBox "Folder does not exist: " & strFolder, _
        vbExclamation, CALLER
        Exit Function
    End If

    ' It exists, so get the folder object.
    Set objFolder = objFso.GetFolder(strFolder)

    ' Open the table containing the attachment field
    Set rstParent = db1.OpenRecordset(strTable)

    rstParent.AddNew
    rstParent.Fields(strPathField).Value = objFolder.Path

    ' Get the first file in this directory.
    strFilePath = Dir(strFolder & strPattern)

    ' Store each file that meets the pattern
    While (Len(strFilePath) > 0)
        Set rstChild = rstParent.Fields(strAttachmentField).Value
        rstChild.AddNew
        Set fldAttach = rstChild.Fields("FileData")
        fldAttach.LoadFromFile strFolder & strFilePath
        rstChild.Update
        rstChild.Close
        strFilePath = Dir() ' Get the next file
    Wend

    ' Commit the new row with the attachments field populated
    ' with all of the files from the current folder.
    rstParent.Update

    ' Recurse into subfolders if requested.
    If (blnIncludeSubfolders) Then
        For Each objSubFolder In objFolder.SubFolders
            StoreFilesInTable objSubFolder.Path, strTable, _
                              strPathField, strAttachmentField, _
                              strPattern, blnIncludeSubfolders, db1
        Next
    End If

Cleanup:
    rstParent.Close
    Set rstParent = Nothing

    Exit Function
StoreFilesInTable_ErrorHandler:
    Debug.Print "Error # " & Err.Number & " in " & CALLER & " : " & Err.Description
    MsgBox Err.Description, vbCritical, "Error # " & Err.Number & " in " & CALLER
    GoTo Cleanup
End Function 'StoreFilesInTable

Sub TestStoreFilesInTable()
    Const strRootFolder As String = "C:\Users\<YourUserName>\Pictures\"
    StoreFilesInTable strRootFolder, "Table1", "FolderPath", "Files", "*.jpg", False
    MsgBox "Done adding files from: " & vbCrLf & strRootFolder & "*.jpg", _
        VbMsgBoxStyle.vbInformation, "TestStoreFilesInTable"
End Sub