Export attachments to folder-CodePudding

I have an Access table that I need to convert to SQL Server, but it has an attachment field. I am trying to export all the attachments to a specified folder and have each attachment files grouped by the primary key folder.

Function ExtractAttachment()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim fld As DAO.Field
Dim savePath As String

    savePath = "\\MyFolder\" 'Folder path to save files

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("tblEmpInfo") 'tblEmpInfo is table name
    Set fld = rst("EmpPhoto") 'EmpPhoto is Field name to table with attachment data type.

    Do While Not rst.EOF 'Loop through all records of table.
    Set rsA = fld.Value
        On Error Resume Next 'Omit errors if file already exist
        Do While Not rsA.EOF 'Loop through all attachment of single record
            rsA.Fields("FileData").SaveToFile savePath & rst.Fields(0) & "\" 'Save file to disk
            rsA.MoveNext
        Loop
    rst.MoveNext
    Loop

    rst.Close
    dbs.Close
Set fld = Nothing
Set rst = Nothing
Set dbs = Nothing
End Function

If I remove & rst.Fields(0) & "\" it creates all the files, but under the same folder and have no way to differentiate them.

How can I export the attachments by folder using the autonumber of the field (Primary Key)?

CodePudding user response：

Need to make sure folder exists and if not, create it.
If Dir(savePath & rst.Fields(0)) = "" Then MkDir savePath & rst.Fields(0)

If you want to include record ID in exported file's name, specify in the destination path. Can still save to subfolders or just all into one folder.

rsA.Fields("FileData").SaveToFile savePath & rst.Fields(0) & "\" & rst.Fields(0) & rsA.Fields("FileName")