Хранение файлов в поле MEMO таблицы БД (DAO)

Пример:

Private Sub TestAll()
Dim x As Long
Dim str As String
'Берем ВСЕ файлы *.dbf из папки в таблицу aflTemplates(с удалением старых записей) ...
'es - 23.05.2016
'
'
'--------------------------------------------------------------------------
On Error GoTo TestAll_Err
    str = CurrentProject.Path & "\Shablon\"
    esPutFilesToTable str, "aflTemplates", "tplName", "tplBody", "*.dbf"
    Exit Sub
    
    
'Выгружаем все файлы - по пути ...\Shablon\COPY2\"
    str = CurrentProject.Path & "\Shablon\COPY2\"
    If Dir(str, vbDirectory) = "" Then PrepareFolders str
    x = esOutPutFilesFromTable(str, "aflTemplates", "tplName", "tplBody")
    If x = 0 Then MsgBox "OK!", vbInformation, "Вывод файла"


TestAll_Bye:
    Exit Sub

TestAll_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: TestAll", vbCritical, "Error in FOMS Reports v030-03"
    Resume TestAll_Bye
End Sub

Модуль:

'--------------------------------------------------------------------------
' Module    : modFilesInDB
' Author    : es
' Date      : 01.02.2011 -23.05.2016
' Purpose   : Хранение файлов в поле MEMO таблицы БД
'             Загрузка - Выгрузка
'--------------------------------------------------------------------------
Public Function esOutPutOneFileFromTable(strFilePath As String, _
                              strTableName As String, _
                              strFieldForFileName As String, _
                              strFieldForFileBody As String, _
                              strFileName As String)
'es 01.02.2011  http://msa.polarcom.ru
'Копируем ОДИН (указанный) файл из таблицы - в указанную папку
'Аргументы:
' 1. strFilePath          = Полный путь к конечному файлу в виде: "C:\Temp\myfile.txt"
' 2. strTableName         = Название таблицы откуда
' 3. strFieldForFileName  = Название поля откуда брать названия файлов
' 4. strFieldForFileBody  = Название поля откуда брать тело файлов
' 5. strFileName          = Название файла
'--------------------------------------------------------------------------

Dim daoRst As DAO.Recordset   'Рабочий набор записей
Dim str As String
Dim v As Variant
Dim i As Long                 'Счетчик файлов
Dim x As Long                 'к-во записей в таблице
On Error GoTo esOutPutOneFileFromTableERR
    
    If Dir(strFilePath) <> "" Then Kill strFilePath 'Удаление файла
    DoEvents

'Определяем набор записей для работы

    
    str = "SELECT * FROM " & strTableName & " WHERE " & strFieldForFileName & " = '" & strFileName & "'"
    Set daoRst = CurrentDb.OpenRecordset(str, dbOpenSnapshot)
    If daoRst.EOF = True Then GoTo esOutPutOneFileFromTableExit
    v = daoRst.Fields(strFieldForFileBody)
    
'Запись файла
    Reset
    Open strFilePath For Output As #1
    Print #1, v;
    Close #1    ' Закрывает файл.
    
'Концовка
esOutPutOneFileFromTableExit:
    On Error Resume Next
    daoRst.Close
    Set daoRst = Nothing
    Close #1
    DoEvents
    Exit Function

esOutPutOneFileFromTableERR: 'Метка обработчика ошибок
    esOutPutOneFileFromTable = Err.Number
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure esOutPutOneFileFromTable of Module modData", vbCritical, "Error!"

    Err.Clear
    Resume esOutPutOneFileFromTableExit
End Function

Private Sub esPutFilesToTable(strStoragePath As String, _
                              strTableName As String, _
                              strFieldForFileName As String, _
                              strFieldForFileBody As String, _
                              Optional strExt As String = "*.*")

'--------------------------------------------------------------------
'es 01.02.2011 - 23.01.2018  http://msa.polarcom.ru
'--------------------------------------------------------------------
'Процедура копирования всех файлов указанной в аргументе
'strStoragePath папки - в таблицу у которой одно поле
'содержит имена исходных файлов, а другое их "тело" (MEMO)
'Аргументы:
' 1. strStoragePath       = путь к файлам в виде: "C:\Temp"
' 2. strTableName         = Название таблицы куда
' 3. strFieldForFileName  = Название поля куда сохранять названия файлов
' 4. strFieldForFileBody  = Название поля куда сохранять тело файлов MEMO!!!
' 5. strExt               = Опционально - Расширение файлов (по умолч.= "*.*")
'--------------------------------------------------------------------------

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 esPutFilesToTableERR

'проверка на наличие левого слеша в аргументе пути (Не должно быть)
    If Mid(strStoragePath, Len(strStoragePath), 1) = "\" Then
        strStoragePath = Mid(strStoragePath, 1, Len(strStoragePath) - 1)
    End If
'проверка на наличие пути
    If Dir(strStoragePath, vbDirectory) = "" Then
        MsgBox "Указанный путь к файлам " & vbCrLf & _
        strStoragePath & vbCrLf & _
        "не существует!!!", vbCritical
        Exit Sub
    End If
    
'Предупреждение об удалении старых данных
    Msg = "Имеющиеся данные из таблицы  =" & strTableName & "=  будут удалены..." & vbCrLf & _
    "Вы уверены ???"
    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 & "\" & strExt)
        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) = strFileName
                        .Fields(strFieldForFileBody) = varVal
                    .Update
                strFileName = Dir    ' Возвращает следующий элемент.
                varVal = Null
                i = i + 1
            Loop
        End With
    
'Концовка
    daoRst.Close
    Set daoRst = Nothing
    MsgBox "В таблицу принято - " & i & " файлов"
    Exit Sub

esPutFilesToTableERR: 'Метка обработчика ошибок
    MsgBox "Произошла ошибка №" & Err.Number & vbCrLf & Err.Description
    Err.Clear
End Sub


Public Function esOutPutFilesFromTable(strStoragePath As String, _
                              strTableName As String, _
                              strFieldForFileName As String, _
                              strFieldForFileBody As String) As Long
'es 01.02.2011  http://msa.polarcom.ru
'Процедура обратная предидущей т.е. из таблицы копируем файлы в указанную папку
'Аргументы:
' 1. strStoragePath       = путь к файлам в виде: "C:\Temp"
' 2. strTableName         = Название таблицы откуда
' 3. strFieldForFileName  = Название поля откуда брать названия файлов
' 4. strFieldForFileBody  = Название поля откуда брать тело файлов
'--------------------------------------------------------------------------
Dim strFileName As String     'Название обрабатываемого файла
Dim strFilePath As String     'Полный путь к обрабатываему в т.в. файлу
Dim daoRst As DAO.Recordset   'Рабочий набор записей
Dim i As Long                 'Счетчик файлов
Dim x As Long                 'к-во записей в таблице
On Error GoTo esOutPutFilesFromTableERR

'проверка на наличие левого слеша в аргументе пути (Не должно быть)
    If Mid(strStoragePath, Len(strStoragePath), 1) = "\" Then
        strStoragePath = Mid(strStoragePath, 1, Len(strStoragePath) - 1)
    End If

'Проверка на наличие пути
    If Dir(strStoragePath, vbDirectory) = "" Then
        MsgBox "Указанный путь к файлам " & vbCrLf & _
        strStoragePath & vbCrLf & _
        "не существует!!!", vbCritical
        Exit Function
    End If

    
    
'Определяем набор записей для работы
    Set daoRst = CurrentDb.OpenRecordset(strTableName, dbOpenSnapshot)
    If daoRst.EOF = True Then GoTo esOutPutFilesFromTableExit
    With daoRst
        .MoveLast
        .MoveFirst
        x = .RecordCount
            'Начинаем перебор записей и вывод файлов
            For i = 1 To x
                strFileName = .Fields(strFieldForFileName)
                
                'Получаем Полный путь к файлу
                    strFilePath = strStoragePath & "\" & strFileName
                'Запись файла
                    Reset
                    Open strFilePath For Output As #1
                    Print #1, .Fields(strFieldForFileBody);
                    Close #1    ' Закрывает файл.
                If i < x Then .MoveNext
            Next i
    End With
    
'Концовка
esOutPutFilesFromTableExit:
    On Error Resume Next
    daoRst.Close
    Set daoRst = Nothing
    MsgBox "Из таблицы скопировано - " & x & " файлов"
    
    Exit Function

esOutPutFilesFromTableERR: 'Метка обработчика ошибок
    esOutPutFilesFromTable = Err.Number
    MsgBox "Произошла ошибка №" & Err.Number & vbCrLf & Err.Description
    Err.Clear
End Function