TopPicLogo TopPicText

Хранение файлов в поле MEMO таблицы БД - Загрузка и выгрузка одного файла

Применяеться когда необходимо хранить файлы в БД (поле Memo)

Загрузка:

Public Function LoadFile(strFilePath As String) As Variant
'es 03.08.2011
'Возвращает "Тело" файла по его полному пути
'-------------------------------------------------------------
Dim lngFileLen As Long
Dim FF As Long
Dim val As Variant

'Открыть файл

    lngFileLen = FileLen(strFilePath)
    Reset 'Если есть открытые - закрываем (на всякий случай)
    'Открываем файл на чтение
    FF = FreeFile()
    Open strFilePath For Binary Access Read Lock Read As #FF
    val = Input(lngFileLen, FF)   ' Читает тело файла.
    LoadFile = val

LoadFileBye:
    Close FF
    Exit Function

LoadFileErr:
    LoadFile = Null
    Resume LoadFileBye

End Function



Выгрузка:

Public Function WriteFile(vBody As Variant, strPath As String) As Long
'es-06.10.2011
'Запись "Тела" файла по заданному пути
'Аргументы:
'   vBody     = Тело файла
'   strPath   = Путь создаваемого файлу
'--------------------------------------------------------------------------
Dim FF As Long
'--------------------------------------------------------------------------
    On Error GoTo WriteFileErr
    If strPath = "" Then
        GoTo WriteFileBye
    End If
'Поехали ...
   ' FF = PrepareFolders(strPath)      'Создаем папки по пути если нужно
   ' If FF > 0 Then Exit Function
    
    FF = FreeFile
    Open strPath For Output As #FF    ' Открывает файл для записи.
    Print #FF, vBody;                 ' Заполняем файл Данными
    Close #FF                         ' Закрывает файл.
    Reset
WriteFileBye:
    On Error Resume Next
    FF = FreeFile
    Exit Function

WriteFileErr:
    'Debug.Print strPath
    MsgBox "Error " & Err.Number & " (" & Err.Description & ")" & vbCrLf & _
    "in procedure WriteFile of Module modUtils", vbCritical, "Error!"
    WriteFile = Err.Number
    Resume WriteFileBye
End Function



Может потребоваться:


Public Function PrepareFolders(strFilePath As String) As Long
'es 20.01.04
'Проверка на наличие и создание папок произвольной вложенности перед
'копированием, перемещением или созданием файла
'В случае возникновения ошибки возвращает ее код и выдает сообщение
'--------------------------------------------------------------------
Dim i As Integer
Dim x As Integer
Dim strTemp As String
Dim curPath As String
On Error GoTo PrepareFoldersErr
    x = Len(strFilePath)
    For i = 1 To x
        If Mid(strFilePath, i, 1) = "\" Then
            curPath = Mid(strFilePath, 1, i - 1)
            If Dir(curPath, vbDirectory) = "" Then
                MkDir curPath
            End If
        End If
    Next i
    Exit Function
PrepareFoldersErr:
    PrepareFolders = Err.Number
    Select Case PrepareFolders
        Case 76 'Невеный путь
            MsgBox "Задан не верный путь:" & vbCrLf & _
            strFilePath, vbExclamation, "PrepareFolders"
        Case Else
            MsgBox "Процедура [PrepareFolders] привела к ошибке:" & vbCrLf & _
            "Аргумент: " & strFilePath & vbCrLf & _
            Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical
    End Select
    Err.Clear
End Function
Назад ToTop
L.E. 23.05.2016
Рейтинг@Mail.ru