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

'----------------------------------------------------------------------------------------------
' Module    : modFilesInDB_ADODB
' Author    : es
' Date      : 07.02.2021 - 13.08.2021 v002
' Purpose   : Хранение файлов в поле MEMO таблицы БД
'             Загрузка - Выгрузка
'----------------------------------------------------------------------------------------------
Private Const cnsTableName$ = "a00Files"    'имя таблицы хранения файлов (Без ПРОБЕЛОВ!!! в названии)
Private Const cnsRecordIDField = "FileID"   'имя поля с ID файла (Без ПРОБЕЛОВ!!! в названии)
Private Const cnsFileNameField = "flName"   'имя поля с названием (Без ПРОБЕЛОВ!!! в названии)
Private Const cnsFileBodyField = "flBody"   'имя поля с телом файла (Без ПРОБЕЛОВ!!! в названии)
Private Const cnsFileLenField = "flLen"     'имя поля с длинной файла
'
Private Sub TestFilesInDB()
'пример эксплуотации
Dim sVal$, lErr&
    lErr = FilesInDBImportOne(1, "d:\Temp\logo_clinic_360_420_v002.gif")
    If lErr > 0 Then Debug.Print lErr
    
    sVal = CurrentProject.Path & AConSubAppFolder
    PrepareFoldersForPath sVal
    lErr = FilesInDBExportOne(1, sVal)
    If lErr > 0 Then Debug.Print lErr
End Sub

Public Function FilesInDBExportOne(lFileID As Long, ByVal sFolderPath As String, _
                Optional bReplase As Boolean, Optional sNewFileName As String = "") As Long
'es 07.02.2021 v001  http://msa.polarcom.ru
'----------------------------------------------------------------------------------------------
'Копируем ОДИН (указанный по ID) файл из таблицы - в указанную папку
'----------------------------------------------------------------------------------------------
'Аргументы:
' 01. sFolderPath          = Полный путь к папке куда: "D:\Temp"
' 02. lFileID              = ID файла в таблице
' 03. bReplase             = Принулительная перезапись! (опционально)
' 04. sNewFileName         = Название файла отличное от того что в таблице (опционально)
'----------------------------------------------------------------------------------------------
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset   'Рабочий набор записей
Dim sVal As String
Dim vFileBody As Variant
Dim sFileName$

On Error GoTo FilesInDBExportOne_Err


'----------------------------------------------------------------------------------------------
'Определяем набор записей для работы:
    Set cnt = CurrentProject.Connection ' Локально
    'cnt.CursorLocation = 3] 'adUseServer (2) - adUseClient (3)
    Set rst = CreateObject("ADODB.Recordset")
    'rst.CursorLocation = 3  'adUseServer (2) - adUseClient (3)
    'rst.LockType = adLockReadOnly 'adLockOptimistic
    sVal = "SELECT * FROM " & cnsTableName & " WHERE (" & cnsRecordIDField & " = " & lFileID & ")"
    
    rst.Open sVal, cnt, adOpenStatic, adLockReadOnly
    If rst.EOF = True Then GoTo FilesInDBExportOne_Exit
    
'Тело файла
    vFileBody = rst.Fields(cnsFileBodyField) 'Берём заказанное значение
    If IsNull(cnsFileBodyField) = True Then GoTo FilesInDBExportOne_Exit
'Название файла
    If sNewFileName = "" Then
        sFileName = rst.Fields(cnsFileNameField) 'Берём заказанное значение
    Else
        sFileName = sNewFileName
    End If

'Прдолжаем:
'----------------------------------------------------------------------------------------
'Полный путь
    If Not Right(sFolderPath, 1) = "\" Then sFolderPath = sFolderPath & "\"
    sVal = sFolderPath & sFileName

    If Not Dir(sVal) = "" Then 'Файл уже есть на HDD
        If bReplase = True Then 'Перезапись!
            Kill sFolderPath 'Удаление файла
            DoEvents
        Else
            GoTo FilesInDBExportOne_Exit
        End If
    End If
    
'Запись (перезапись) файла
    Reset
    Open sVal For Output As #1
    Print #1, vFileBody;

FilesInDBExportOne_Exit: 'Концовка
    On Error Resume Next
    Close #1    ' Закрывает файл.
    DoEvents
    
    rst.Close: Set rst = Nothing
    cnt.Close: Set cnt = Nothing
    
    Err.Clear
    Exit Function

FilesInDBExportOne_Err: 'Метка обработчика ошибок
    FilesInDBExportOne = Err.Number
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure FilesInDBExportOne of Module [modFilesInDB_ADODB]", vbCritical, "Error!"
    Err.Clear
    Resume FilesInDBExportOne_Exit
End Function


Public Function FilesInDBImportOne(lFileID As Long, sFilePath$)
'es - 07.02.2021    http://msa.polarcom.ru
'----------------------------------------------------------------------------------------------
'Копируем ОДИН (указанный по ID) файл в таблицу
'----------------------------------------------------------------------------------------------
'Аргументы:
' 01. sFilePath            = Полный путь к исходному фалу: "D:\Temp\Название.txt"
' 02. lFileID              = ID файла в таблице
'----------------------------------------------------------------------------------------------
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset   'Рабочий набор записей
Dim vFileBody As Variant
Dim sFileName$
Dim sVal As String, lFileLen&

On Error GoTo FilesInDBImportOne_Err

    If Dir(sFilePath, vbNormal) = "" Then
        sVal = "Файл:" & vbCrLf & sFilePath & vbCrLf & "Не найден!" & vbCrLf & _
            "Ошибка в Function FilesInDBImportOne - modFilesInDB_ADODB."
        MsgBox sVal, vbCritical, "Произошла ошибка!"
        GoTo FilesInDBImportOne_End
    End If
'----------------------------------------------------------------------------------------------
    lFileLen = FileLen(sFilePath)
    sFileName = GetFileNameByPath(sFilePath)

'Определяем набор записей для работы:
    Set cnt = CurrentProject.Connection ' Локально
    'cnt.CursorLocation = 3 'adUseServer (2) - adUseClient (3)
    Set rst = CreateObject("ADODB.Recordset")
    'rst.CursorLocation = 3 'adUseServer (2) - adUseClient (3)
    'rst.LockType = adLockReadOnly 'adLockOptimistic
    sVal = "SELECT * FROM " & cnsTableName & " WHERE (" & cnsRecordIDField & " = " & lFileID & ")"
    rst.Open sVal, cnt, adOpenDynamic, adLockOptimistic
    If rst.EOF = True Then
        rst.AddNew
        rst(cnsRecordIDField) = lFileID
    End If
    
    
    Reset 'Если есть открытые - закрываем на усякий случай
    'Открываем файл на чтение
    Open sFilePath For Binary Access Read Lock Read As #1
    vFileBody = Input(lFileLen, #1)   ' Читает тело файла.
    'Close #1    ' Закрывает файл.
    
    'Собственно добавление в таблицу "выжатых" их файла байтов
    rst.Fields(cnsFileNameField) = sFileName
    rst.Fields(cnsFileBodyField) = vFileBody
    rst.Fields(cnsFileLenField) = lFileLen
    rst.Update
    
FilesInDBImportOne_End:
    On Error Resume Next
    Close #1    ' Закрывает файл.
    DoEvents
    
    rst.Close: Set rst = Nothing
    cnt.Close: Set cnt = Nothing
    
    Err.Clear
    Exit Function

FilesInDBImportOne_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function" & _
           "FilesInDBImportOne - modFilesInDB_ADODB.", vbCritical, "Произошла ошибка!"
    'Debug.Print "FilesInDBImportOne_Line: " & Erl & "."
    Err.Clear
    Resume FilesInDBImportOne_End

End Function