Копирование файлов из папки в базу данных и
копирование файлов из базы данных в папку:

Sub Test()
'Берём файлы
Call JsPutFilesToTable("C:\Temp\1", "tblImageDir", "ПолеtxtFileName", "ПолеmemoFileBody")
'Выгружаем файлы
Call JsOutPutFilesFromTable("C:\Temp\2", "tblImageDir", "ПолеtxtFileName", "ПолеmemoFileBody")
End Sub

Private Sub JsPutFilesToTable(strStoragePath As String, strTableName As String, strFieldForFileName As String, strFieldForFileBody As String)
'Процедура копирования всех файлов указанной в аргументе
'strStoragePath папки - в таблицу, у которой одно поле
'содержит имена исходных файлов, а другое их "тело" (memo)
'Аргументы:
'strStoragePath      - Путь к файлам в виде: "C:\Temp\1"
'strTableName        - Название таблицы куда
'strFieldForFileName - Название поля куда сохранять названия файлов
'strFieldForFileBody - Название поля куда сохранять тело файлов (memo)
Dim Msg As String, Style As Integer 'Для вывода сообщения - предупреждения
Dim strFileName As String     'Название обрабатываемого файла
Dim strFilePath As String     'Полный путь к обрабатываемому файлу
Dim varVal As Variant         'Для временного хранения тела файла
Dim daoRst As DAO.Recordset   'Рабочий набор записей
Dim i As Long                 'Счётчик файлов
Dim lngFileLen As Long        'Размер файла
On Error GoTo JsPutFilesToTableERR
'Проверка на наличие левого слеша в аргументе пути (не должно быть)
If Mid(strStoragePath, Len(strStoragePath), 1) = "\" Then
strStoragePath = Mid(strStoragePath, 1, Len(strStoragePath) - 1)
End If
'Проверка на наличие пути
If Dir(strStoragePath, vbDirectory) = "" Then
MsgBox "Указанный путь к файлам" & vbNewLine & strStoragePath & vbNewLine & "не существует!", vbCritical
Exit Sub
End If
'Предупреждение об удалении старых данных
Msg = "Данные из таблицы " & strTableName & " будут удалены." & vbNewLine &"Вы уверены?"
Style = vbYesNo + vbExclamation + vbDefaultButton1
If MsgBox(Msg, Style, "Предупреждение") = vbNo Then Exit Sub
'Удаляем всё старое из таблицы
DoCmd.SetWarnings False
CurrentDb.Execute "Delete*From " & strTableName
'Определяем набор записей для заполнения
Set daoRst = CurrentDb.OpenRecordset(strTableName, dbOpenDynaset)
'Начинаем перебор файлов в папке (не взирая на личности - все)
strFileName = Dir(strStoragePath & "\*.*")
With daoRst
'Цикл по всем файлам в папке
Do While strFileName <> ""                       'Начало цикла
strFilePath = strStoragePath & "\" & strFileName 'Полный путь
lngFileLen = FileLen(strFilePath)
'Если есть открытие, то закрываем на всякий случай
Reset
'Открываем файл для чтения
Open strFilePath For Binary Access Read Lock Read As #1
varVal = Input(lngFileLen, #1) 'Читаем тело файла
Close #1                       'Закрываем файл
'Добавление в таблицу "выжатых" из файла байтов
.AddNew
.Fields(strFieldForFileName) = strStoragePath & "\" & strFileName
.Fields(strFieldForFileBody) = varVal
.Update
strFileName = Dir 'Возвращает следующий элемент
varVal = Null
i = i + 1
Loop
End With
'Концовка
daoRst.Close
Set daoRst = Nothing
MsgBox "В таблицу скопировано " & i & " файлов."
Exit Sub
JsPutFilesToTableERR: 'Метка обработчика событий
MsgBox "Произошла ошибка №" & Err.Number & vbNewLine & Err.Description
Err.Clear
End Sub

'/////////////////////////////////////////////////////////////////////

Private Sub JsOutPutFilesFromTable(strStoragePath As String, strTableName As String, strFieldForFileName As String, strFieldForFileBody As String)
'Процедура обратная предыдущей, то есть
'из таблицы копируем файлы в указанную папку
'Аргументы:
'strStoragePath      - Путь к файлам в виде: "C:\Temp\2"
'strTableName        - Название таблицы откуда
'strFieldForFileName - Название поля откуда брать названия файлов
'strFieldForFileBody - Название поля откуда брать тело файлов (memo)
Dim strFileName As String     'Название обрабатываемого файла
Dim strFilePath As String     'Полный путь к обрабатываемому файлу
Dim daoRst As DAO.Recordset   'Рабочий набор записей
Dim i As Long                 'Счётчик файлов
Dim x As Long        'Количество записей в таблице
On Error GoTo JsOutPutFilesFromTableERR
'Проверка на наличие левого слеша в аргументе пути (не должно быть)
If Mid(strStoragePath, Len(strStoragePath), 1) = "\" Then
strStoragePath = Mid(strStoragePath, 1, Len(strStoragePath) - 1)
End If
'Проверка на наличие пути
If Dir(strStoragePath, vbDirectory) = "" Then
MsgBox "Указанный путь к файлам" & vbNewLine & strStoragePath & vbNewLine & "не существует!", vbCritical
Exit Sub
End If
'Определяем набор записей для работы
Set daoRst = CurrentDb.OpenRecordset(strTableName, dbOpenSnapshot)
If daoRst.EOF = True Then GoTo JsOutPutFilesFromTableExit
With daoRst
.MoveLast
.MoveFirst
x = .RecordCount
'Начинаем перебор записей и вывод файлов
For i = 1 To x
strFileName = .Fields(strFieldForFileName)
'Получаем полный путь к файлу
strFilePath = strFileName
'Запись файла
Reset
Open strFilePath For Output As #1
Print #1, .Fields(strFieldForFileBody);
Close #1 'Закрываем файл
If i < x Then .MoveNext
Next i
End With
'Концовка
JsOutPutFilesFromTableExit:
daoRst.Close
Set daoRst = Nothing
MsgBox "В папку " & strStoragePath & " скопировано " & x & " файлов."
Exit Sub
JsOutPutFilesFromTableERR: 'Метка обработчика событий
MsgBox "Произошла ошибка №" & Err.Number & vbNewLine & Err.Description
Err.Clear
End Sub