none
Extracting attachments from Access database RRS feed

  • Question

  • I am needing to extract the attachments from an Access database and save them on our network.    The code I have listed below is not working for me. Has anyone done that and be willing to give me direction? Thank you!

    Option Explicit

    Dim conn, fso, db_file, connstring, SQL, Server, strAllFields, i, Value
    Dim rs, rsA, rsB, fld, OrdID
    Dim DID, Attachments, Filename
    Dim fields(0), tfield

    'Create an instance of the ADO connection and recordset objects.
    Set conn = createobject("ADODB.connection")
    Set fso = createobject("scripting.filesystemobject")
    Set rs = createobject("ADODB.recordset")
    Set rsA = createobject("ADODB.recordset")
    'Declare the SQL statement that will query the database.
    SQL = "Select DID, Attachments, Attachments.FileName from ROIAttachments"

    'Open the connection to the database.
    connstring = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
      "Data Source=K:\Inpatient\Database\ROI Attachments.accdb;" & _
      "Persist Security Info=False"

    conn.open connstring

    fields(0) = "Denial Notification"

    'On Error Resume Next

    For each tfield in fields
     If tfield <> "" then
      Set rs = conn.Execute(SQL)
      Set fld = rs(0)
      Set OrdID = rs("DID")
      
      If rs.EOF = False then
       rs.MoveFirst
        Do 
         Set rsA = fld.Value
         rsB = OrdID.Value
         While not rsA.EOF
          DoEvents
          strPath = "Z:\ROI Attachment db downloaded files"
          strFullPath = strPath & "\" & rsB & tfield & " " & rsA("FileName")
          Debug.Print rsB
           
          rsA.Fields("FileData").SaveToFile strFullPath
          rsA.MoveNext
         Wend   
         MsgBox rs.Fields(0) & " " & rs.Fields(1) & " " & rs.Fields(2)
         rs.MoveNext
        Loop until rs.EOF = True
      End If
     End If 
     
    Next

    Friday, September 23, 2016 8:09 PM

Answers

  • I use DAO for this operation since the Attachment type is specific to Microsoft Access and has a unique structure:

            Dim DatabasePath As String = "C:\Users\...\Documents\My Database\Access\Attachment.accdb"
            Dim AccessEngine As New Microsoft.Office.Interop.Access.Dao.DBEngine
            Dim SourceRecordset As Microsoft.Office.Interop.Access.Dao.Recordset
            Dim AttachmentRecordset As Microsoft.Office.Interop.Access.Dao.Recordset
    
            Dim db As Microsoft.Office.Interop.Access.Dao.Database = AccessEngine.OpenDatabase(DatabasePath)
    
            SourceRecordset = db.OpenRecordset("SELECT * FROM Table1 WHERE ID = 1")
            AttachmentRecordset = SourceRecordset.Fields("MyAttachments").Value
            While Not AttachmentRecordset.EOF
                Dim AttachmentFileName As String = AttachmentRecordset.Fields("FileName").Value.ToString
                Dim AttachmentPath As String = System.Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments) & "\Test\" & AttachmentFileName
                AttachmentRecordset.Fields("FileData").SaveToFile(AttachmentPath)
                AttachmentRecordset.MoveNext()
            End While
    
            SourceRecordset.Close()
            SourceRecordset = Nothing
            AttachmentRecordset = Nothing
            db.Close()
            db = Nothing


    Paul ~~~~ Microsoft MVP (Visual Basic)

    Friday, September 23, 2016 9:07 PM