Выгрузка вложений (Attachments) из таблицы в папку с нумерацией выгружаемых файлов

По материалам: https://www.cyberforum.ru/ms-access/thread3054317.html#post16615845

В модуле формы:

Private Sub CommandExportAll_Click()
    AttachmentsExport ' Выгрузить все! (без аргумента)
End Sub

Private Sub CommandExportCurrentOnly_Click()
' Выгрузить только этот
    AttachmentsExport Nz(Me.Код, 0)
End Sub

Функция:

Public Sub AttachmentsExport(Optional lRecKey&)
' Выгрузка вложений (Attachments) из таблицы в папку с нумерацией - всех записей или только одной
' Аргумент: lRecKey = Значение ключа записи
'---------------------------------------------------------------------------------------------------
Dim rst As DAO.Recordset
Dim rsAttachments As DAO.Recordset
Dim sFilePath$, sVal$, lRecID, lRecNo&, lNo&

Const csSourceTableName$ = "DataTest"          ' Таблица - Откуда
Const csSourceKeyFieldName$ = "Код"            ' Таблица - Откуда - Имя ключевого поля
Const csSourceAttachmentField$ = "Вложение"    ' Таблица - Откуда - Имя поля с вложением
Const csDistFolder$ = "D:\Temp\"               ' Папка - Куда
Const csRecNoFormat$ = "000000"                ' Формат номера записи в названии файла
Const csFileNoFormat$ = "000"                  ' Формат номера файла в названии файла
 
On Error GoTo AttachmentsExport_Err
    
    If lRecKey > 0 Then
        sVal = " WHERE (" & csSourceKeyFieldName & " = " & lRecKey & ")"
    End If
    sVal = "SELECT * FROM " & csSourceTableName & sVal
    
    Set rst = CurrentDb.OpenRecordset(sVal, dbOpenSnapshot)
    With rst 'Перебор всех записей в наборе
        Do Until .EOF = True 'Цикл до конца набора
            lRecID = .Fields(csSourceKeyFieldName) 'код записи
            Set rsAttachments = .Fields(csSourceAttachmentField).Value
            Do While Not rsAttachments.EOF
                'Получение пути к файлу:
                lNo = lNo + 1
                sFilePath = csDistFolder & "RecID_" & Format(lRecID, csRecNoFormat) & _
                        "_FileNo_" & Format(lNo, csFileNoFormat) & _
                        "_" & rsAttachments!FileName
                
                'Перезапись если файл уже существует:
                If Not Dir(sFilePath) = "" Then   'файл уже существует
                    Kill sFilePath                'удаляем ...
                    DoEvents
                End If
                
                rsAttachments!FileData.SaveToFile sFilePath
                rsAttachments.MoveNext           'Следующее вложение
            Loop
            DoEvents
            lRecNo = lRecNo + 1
            .MoveNext
        Loop
    End With
    
    If lNo > 0 Then _
        MsgBox "Выгружено " & lNo & " файлов из " & lRecNo & " записей", vbInformation
 
AttachmentsExport_End:
    On Error Resume Next
    rst.Close:              Set rst = Nothing
    rsAttachments.Close:    Set rsAttachments = Nothing
    Err.Clear
    Exit Sub
 
AttachmentsExport_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub : " & _
           "AttachmentsExport - modAttachmentsExport.", vbCritical, "Error!"
    Err.Clear
    Resume AttachmentsExport_End
End Sub

MSA-2007 и выше (3 629 kB) Пример