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

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

Private Sub cmdВашаКнопка_Click()
'Выгрузка всех вложений (Attachments) из таблицы в папку с нумерацией
'---------------------------------------------------------------------------------------------------
Dim rst As DAO.Recordset
Dim rsAttachments As DAO.Recordset
Dim sFilePath$, lRecID, iNo%

Const csSourceTableName$ = "DataTest"      'Таблица - Откуда
Const csAttFieldName$ = "TestAttachment"   'Имя поля с вложениями - Откуда
Const csDistFolder$ = "D:\Temp\"           'Папка - Куда
Const csRecNoFormat$ = "000000"            'Формат номера записи в названии файла
Const csFileNoFormat$ = "000"              'Формат номера файла в названии файла

On Error GoTo cmdВашаКнопка_Click_Err

    Set rst = CurrentDb.OpenRecordset(csSourceTableName, dbOpenSnapshot)
    With rst 'Перебор всех записей в наборе
        Do Until .EOF = True 'Цикл до конца набора
            lRecID = !RecIDAuto 'код записи
            iNo = 0
            Set rsAttachments = Me.Recordset(csAttFieldName).Value
            Do While Not rsAttachments.EOF
                iNo = iNo + 1
                'Путь к файлу типа: "D:\Temp\Rec000099_FNo003_Имя Вложенного Фала.doc"
                sFilePath = csDistFolder & "Rec" & Format(lRecID, csRecNoFormat) & _
                        "_FNo" & Format(iNo, csFileNoFormat) & _
                        "_" & rsAttachments!FileName
                'Перезапись:
                If Not Dir(sFilePath) = "" Then   'файл уже существует
                    Kill sFilePath                'удаляем ...
                    DoEvents
                End If
                
                'Debug.Print "Выгружаю: " & sFilePath
                rsAttachments!FileData.SaveToFile sFilePath
                rsAttachments.MoveNext           'Следующее вложение
            Loop
            DoEvents
            .MoveNext
        Loop
    End With

cmdВашаКнопка_Click_End:
    On Error Resume Next
    rst.Close: Set rst = Nothing
    rsAttachments.Close
    Set rsAttachments = Nothing
    Err.Clear
    Exit Sub

cmdВашаКнопка_Click_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub : " & _
           "cmdВашаКнопка_Click - Form_DataTest.", vbCritical, "Error!"
    Err.Clear
    Resume cmdВашаКнопка_Click_End
End Sub