How to export attachments (images) with a given name to a folder?

Question

My ex-colleague built an Access database with many record sets and each of them has one to five pictures attached. The size of the database is now really big (about 2 GB) and it

Answer 1

after two days digging, I could figure out what I wanted. Now, I can export all the attachments from the database to a given folder, insert the path and name of the picture into the database and resize my database from 2GB to 8MB! YESSS!

Please ask,if you had questions. Here is the code for that:

sub exportAttachments()

Dim strPath, fName, fldName, sName(3)  As String
Dim rsPictures, rsDes  As Variant
Dim rs As DAO.Recordset
Dim savedFile, i As Integer
savedFile = 0

strPath = Application.CurrentProject.Path

Set rs = CurrentDb.OpenRecordset("SELECT * FROM Employees")

'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
    rs.MoveFirst 'Not required here, but still a good habit
    Do Until rs.EOF = True        
        On Error Resume Next 'ignore errors

       'Instantiate the child record set.
        Set rsPictures = rs.Fields("Attachments").Value
        Set rsDes = rs.Fields("Name") 'use to name the picture later

        'if no attachment available, go to next record
        If Len(rsPictures.Fields("FileName")) = 0 Then
         GoTo nextRS
        End If
        If rsPictures.RecordCount <> 0 Then 
        rsPictures.MoveLast
        savedFile = rsPictures.RecordCount 'set savedFile = total no of attachments
        End If
    rsPictures.MoveFirst ' move to first attachment file

  'WARNING: all of my attachments are picture with JPG extension. 
  'loop through all attachments
        For i = 1 To savedFile 'rename all files and save
            If Not rsPictures.EOF Then
                fName = strPath & "\Attachments\" & rsDes & i & ".JPG"
                rsPictures.Fields("FileData").SaveToFile fName
                sName(i) = fName 'keep path in an array for later use
                rsPictures.MoveNext
            End If
        Next i

        'insert image name and path into database an edit
        rs.Edit

            If Len(sName(1)) <> 0 Then
                rs!PicPath1 = CStr(sName(1)) 'path
                rs!PicDes1 = Left(Dir(sName(1)), InStr(1, Dir(sName(1)), ".") - 1) 'file name without extension
            End If
            If Len(sName(2)) <> 0 Then
                rs!PicPath2 = CStr(sName(2))
                rs!PicDes2 = Left(Dir(sName(2)), InStr(1, Dir(sName(2)), ".") - 1)
            End If
            If Len(sName(3)) <> 0 Then
                rs!PicPath3 = CStr(sName(3))
                rs!PicDes3 = Left(Dir(sName(3)), InStr(1, Dir(sName(3)), ".") - 1)
            End If

        rs.Update 'update record
nextRS:
        rsPictures.Close 'close attachment
        savedFile = 0 'reset for next
        fName = 0 'reset

        'Move to the next record.
     rs.MoveNext
    Loop

Else
    MsgBox "There are no records in the recordset."
End If

MsgBox "Attachments were exported!"

rs.Close 'Close the db recordsets
Set rs = Nothing 'Clean up

End Sub

Answer 2

Create a new module

From the menu:

Create -> Module (it is in the right corner)

Create the following function (mostly this is copy/paste from Microsoft Documentation)

    Public Function SaveAttachments(strPath As String, Optional strPattern As String = "*.*") As Long
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset2
    Dim rsA As DAO.Recordset2
    Dim fld As DAO.Field2
    Dim strFullPath As String
    
    'Get the database, recordset, and attachment field
    Set dbs = CurrentDb

    '
    ' MODIFY THIS LINE
    '
    Set rst = dbs.OpenRecordset("NAME_OF_THE_TABLE")
    '
    ' MODIFY THIS LINE
    '
    Set fld = rst("TABLE_FIELD_WITH_THE_ATTACHMENTS")
    
    'Navigate through the table
    Do While Not rst.EOF
    
        'Get the recordset for the Attachments field
        Set rsA = fld.Value
        
        'Save all attachments in the field
        Do While Not rsA.EOF
            If rsA("FileName") Like strPattern Then
                strFullPath = strPath & "\" & rsA("FileName")
                
                'Make sure the file does not exist and save
                If Dir(strFullPath) = "" Then
                    rsA("FileData").SaveToFile strFullPath
                End If
                
                'Increment the number of files saved
                SaveAttachments = SaveAttachments + 1
            End If
            
            'Next attachment
            rsA.MoveNext
        Loop
        rsA.Close
        
        'Next record
        rst.MoveNext
    Loop
    
    rst.Close
    dbs.Close
    
    Set fld = Nothing
    Set rsA = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Function

Sub ExportData()
  '
  ' MODIFY THIS LINE
  '
  SaveAttachments ("PATH_TO_THE_DIRECTORY_WHERE_YOU_WANT_THE_FILES_STORED")
End Sub

Then run this (F5)