VBA code to save attachments in specific folder (1 Viewer)

[tachyon1]

I currently have a table ("Transfer Table") with records containing a numeric primary key and an attachments field. There are multiple files in the attachment field stored.

i've been having difficulty trying to adapt microsoft's VBA code example and other people's coding to do the following

For each attachment, save it into directory with the name of the primary key within a static directory (i.e. "C:\Users\" & User & "\Desktop\New Folder").

For example, if the first record had a primary key of 5 and had files A.jpeg, B.jpeg and C.jpeg. The files would be saved and appear like this:

• C:\Users\JoeBloggs\Desktop\New Folder\5\A.jpeg
• C:\Users\JoeBloggs\Desktop\New Folder\5\B.jpeg
• C:\Users\JoeBloggs\Desktop\New Folder\5\C.jpeg

The next record would have a primary key of 23 and has files D.jpeg, E.jpeg, F.jpeg, Z.jpeg. The files would be saved and appear like this:

• C:\Users\JoeBloggs\Desktop\New Folder\23\D.jpeg
• C:\Users\JoeBloggs\Desktop\New Folder\23\E.jpeg
• C:\Users\JoeBloggs\Desktop\New Folder\23\F.jpeg
• C:\Users\JoeBloggs\Desktop\New Folder\23\Z.jpeg

the VBA code would have to go through each record in turn and save all the attachments to their corresponding primary key directories.

Please help.

 

[arnelgp]

you may try this pass to the procedure the name of table, the name of attachment field, the name of you primary key field:

Public Sub AttachmentToDisk(strTableName As String, _
        strAttachmentField As String, strPrimaryKeyFieldName As String)

    Dim strFileName As String
    
    Dim db As DAO.Database
    Dim rsParent As DAO.Recordset2
    Dim rsChild As DAO.Recordset2
    Dim fld As DAO.Field2
    
    Dim strPath As String
    
    strPath = SpecialFolderPath("Desktop") & "\"
    
    Set db = CurrentDb
        
    Set rsParent = db.OpenRecordset(strTableName, dbOpenSnapshot)

    With rsParent
        If .RecordCount > 0 Then .MoveFirst
        
        While Not .EOF
            ' our picture is in the field "pics"
            Set rsChild = rsParent(strAttachmentField).Value
        
            If rsChild.RecordCount > 0 Then rsChild.MoveFirst
            
            While Not rsChild.EOF
        
                ' this is the actual image content
                Set fld = rsChild("FileData")
                
                ' create full path and filename
                strFileName = strPath & .Fields(strPrimaryKeyFieldName) & "\" & rsChild("FileName")
                
                ' remove any previous picture from disk it there is any
                If Len(Dir(strFileName)) <> 0 Then Kill strFileName
                
                ' save our picture to disk
                fld.SaveToFile strFileName
                
                ' move to next attachment
                rsChild.MoveNext
            Wend
            
            ' move record pointer of parent
            .MoveNext
        Wend
    
    End With
    
    
    Set fld = Nothing
    Set rsChild = Nothing
    Set rsParent = Nothing
    Set db = Nothing

End Sub


    Public Function SpecialFolderPath(strFolder As String) As String
        ' Find out the path to the passed special folder. User on of the following arguments:
        ' Options For specical folders
    '        AllUsersDesktop
    '        AllUsersStartMenu
    '        AllUsersPrograms
    '        AllUsersStartup
    '        Desktop
    '        Favorites
    '        Fonts
    '        MyDocuments
    '        NetHood
    '        PrintHood
    '        Programs
    '        Recent
    '        SendTo
    '        StartMenu
    '        Startup
    '        Templates
     
       On Error GoTo ErrorHandler
     
       'Create a Windows Script Host Object
          Dim objWSHShell As Object
          Set objWSHShell = CreateObject("WScript.Shell")
     
       'Retrieve path
          SpecialFolderPath = objWSHShell.SpecialFolders(strFolder & "")
     
CleanUp:
       ' Clean up
          Set objWSHShell = Nothing
          Exit Function
     
    '**************************************
    '*      Error Handler
    '**************************************
ErrorHandler:
        MsgBox "Error finding " & strFolder, vbCritical + vbOKOnly, "Error"
        Resume CleanUp
    End Function

 

[tachyon1]

Thanks arnelgp.

Used a public subroutine to call the "AttachmentToDisk" sub however the following error message appears:

"Run-time error '-2147024893 (800700003)

<Unknown Error-message>HRESULT: &H80070003"

the error is indicating a problem with the "fld.SaveToFile strFileName" line.

the subroutine to call the code that you have made is as follows:

public sub CreateAtt()

Call AttachmentToDisk("Transfer Table", "Attachments", "ID")

end sub

 

[arnelgp]

it does not automatically create the folder/directory, ok i already fixed this one

Public Sub AttachmentToDisk(strTableName As String, _
        strAttachmentField As String, strPrimaryKeyFieldName As String)

    Dim strFileName As String
    
    Dim db As DAO.Database
    Dim rsParent As DAO.Recordset2
    Dim rsChild As DAO.Recordset2
    Dim fld As DAO.Field2
    
    Dim strPath As String
    
    strPath = SpecialFolderPath("Desktop") & "\"
    
    Set db = CurrentDb
        
    Set rsParent = db.OpenRecordset(strTableName, dbOpenSnapshot)

    With rsParent
        If .RecordCount > 0 Then .MoveFirst
        
        While Not .EOF
            ' our picture is in the field "pics"
            Set rsChild = rsParent(strAttachmentField).Value
        
            If rsChild.RecordCount > 0 Then rsChild.MoveFirst
            
            While Not rsChild.EOF
        
                ' this is the actual image content
                Set fld = rsChild("FileData")
                
                ' create full path and filename
                strFileName = strPath & .Fields(strPrimaryKeyFieldName) & "\" & rsChild("FileName")
                
                ' create directory if it does not exists
                If Len(Dir(strPath & .Fields(strPrimaryKeyFieldName), vbDirectory)) = 0 Then VBA.MkDir strPath & .Fields(strPrimaryKeyFieldName)
                ' remove any previous picture from disk it there is any
                If Len(Dir(strFileName)) <> 0 Then Kill strFileName
                
                ' save our picture to disk
                fld.SaveToFile strFileName
                
                ' move to next attachment
                rsChild.MoveNext
            Wend
            
            ' move record pointer of parent
            .MoveNext
        Wend
    
    End With
    
    
    Set fld = Nothing
    Set rsChild = Nothing
    Set rsParent = Nothing
    Set db = Nothing

End Sub

 

[tachyon1]

Thanks. absolutely brilliant.

the code was saving the files in the correct directories but putting them on the desktop rather than in the directory "New folder". just added the directory on the end of the SpecialFolderPath function and it works fantastically.

because the directory "New folder" doesn't always exist i added a mkdir statement after it creates the full path and file name.

once again. thank you