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 is really slow.

I managed instead of including the pictures in the database attachment, to just store the path and the name of the picture as strings in the columns and then recall them whenever I need to do that.

Now I have to export all of the existing images (about 3000 pictures) from the database to a folder after renaming them (with their description stored in another column in the DB, because now their names are like IMG_####, and I don't want to find AND rename them manually after exporting).

I've found something on the internet. But it just exports the attachment of the first record set only. How could I modify this to my need?

Dim strPath As String
Dim rs As DAO.Recordset
Dim rsPictures As Variant
strPath = Application.CurrentProject.Path

'????How to loop through all record set???
'  Instantiate the parent recordset.
   Set rs = CurrentDb.OpenRecordset("Assets")

   ' Instantiate the child recordset.
   Set rsPictures = rs.Fields("Attachments").Value

   '  Loop through the attachments.
   While Not rsPictures.EOF
       '????How to rename the picture???

      '  Save current attachment to disk in the "My Documents" folder.
      rsPictures.Fields("FileData").SaveToFile strPath & "\Attachment"
      rsPictures.MoveNext
   Wend

Gearalt

Filesystem v. DB storage is a bit of a holy war topic. Have you considered just migrating to a more robust backend like SQL Server? – Scaffold

Um, just do the same kind of While Not rs.EOF loop that you already have for rsPictures for the main rs. – Gunrunning

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

Gearalt

thanks so much for posting answer! i never used VB before but with just a few minutes of fiddling with your code, finished very similar task for a friend. Took me just 6 techno songs thanks to you. – Ecumenicity

Did some slight adjustments, but exactly what I needed. I'll export all the attachment to a directory, then read them in as Byte[] to put them in the SQL Database.. THANKS! – Heterograft

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)

Immunoreaction