excel vba to retreive/download attachment form accdb database with specific "ID No."

Question

Hi is there anyone out there who could help me with my problem?
below is the sample of the code which downloads "all" the attachments from my database. However, the problem is I would only like to download an attachment where ID No. = 1. Please help. thanks!

Sub test()
    SaveAttachments "C:\Desktop\"
End Sub

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 = OpenDatabase(Name:="S:\May Tracker.accdb")

    Set rst = dbs.OpenRecordset("Cash")
    Set fld = rst("Payment Details")
   
    '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

Answer 1

Hi,

When you say ID=1, are you referring to the ID value of the record or the attachment? In other words, are you asking how to extract the first attachment only? Or, are you asking how to extract all the attachments of only one record from the table?

Answer 2

Hi .theDBguy,

Thanks for your reply. Yes, I am referring to the ID value of the record. I am asking how to extract all the attachments of only one record from the table, considering that if I will type ID No. = 1, it will extract all attachments in record with ID no. 1, I will type ID No. = 2 then it will extract  all attachments in record with ID no. 2 and so forth and so on. FYI.

Answer 3

ciao Vlady,

what about this, customizing all reference about exportation path and sql predicatoe ogf your scenario :

Private Sub exportAttachments()
 On Error GoTo errHandler
 
    Dim rst             As dao.Recordset2
    Dim rstAttach       As dao.Recordset2
    Dim fldAttach       As dao.Field2
    Dim strSaveFullFile As String

    Const strSavepath As String = "c:\exporatatioPath\" ' to be customized"

    Set rst = DBEngine(0)(0).OpenRecordset("SELECT * FROM  yourTable WHERE IDPK = " & Me.IDPK, 4) 'dbforwardonly customze tableName and PkName
    Set fldAttach = rst!Attachments
    Set rstAttach = fldAttach.Value

    Do While Not rstAttach.EOF

        strSaveFullFile = strSavepath & "\" & rstAttach!FileName

        If FileExists(strSaveFullFile) Then Kill strSaveFullFile  ' be careful here, if the file exists routine will delete  it before saving   !!!!!
        rstAttach!FileData.SaveToFile strSaveFullFile
        rstAttach.MoveNext
    Loop
    VBA.MsgBox prompt:="Attachment Saved", _
               buttons:=vbInformation, _
               Title:="Information"        

exitErrHandler:
    rstAttach.Close
    Set fldAttach = Nothing
    Set rstAttach = Nothing
    Exit Sub

errHandler:
     With Err
        MsgBox "ERR#" & .Number _
             & vbNewLine & .Description _
             , vbOKOnly Or vbCritical
      End With
Resume exitErrHandler

End Sub

Private Function FileExists(ByVal strPathFile As String) As Boolean
     On Error Resume Next
     FileExists = ((GetAttr(strPathFile) And vbDirectory) = 0)
 End Function

HTH, ciao, Sandro.

Answer 4

Hello,

You could add a new parameter ID to the Function and validate ID field value in the loop.

Here is the example modified from your code.

Sub test()
Call SaveAttachments("C:\Desktop\", 3)
End Sub
Public Function SaveAttachments(strPath As String, ID As Integer, Optional strPattern As String = "*.*") As Long  'new parameter 
    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 = OpenDatabase(Name:="S:\May Tracker.accdb") 
    Set rst = dbs.OpenRecordset("Cash")
    Set fld = rst("Payment Details")
   
    'Navigate through the table
    Do While Not rst.EOF
        If rst("ID") = ID Then   '!!!!!!!! New Code    
        '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
         End If   '!!!!!!! New Code
        'Next record
        rst.MoveNext
    Loop
    rst.Close
    dbs.Close
    Set fld = Nothing
    Set rsA = Nothing
    Set rst = Nothing
    Set dbs = Nothing
End Function

Regards,

Celeste

---

MSDN Community Support
Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact [e-mail].

Answer 5

Hi Celeste,

Thanks a lot. The code is working.

Answer 6

Hello,

If your issue has been resolved, I suggest you mark helpful post as answer to close this thread.

If your issue persists, please let me know. And if you have any new issue, please feel free to post new threads.

Regards,

Celeste

---

MSDN Community Support
Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact [e-mail].