Хранение файлов в поле 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

Применение:

Ну, всё просто:
В форме или RecordSet (при пакетной обработке) , пишем:

Me!ИмяПоляМЕМО = LoadFile([Полный путь к файлу])

Вот и всё.

Обратная операция немного сложнее:

WriteFile Me!ИмяПоляМЕМО, [Полный путь к файлу]

Тут аргументами функции являются:
01. - Ссылка на поле с телом файла
02. - Полный путь для его сохранения

Причём :
Если вы сохраните (выгрузите) тело файла "DOCX" как "XLS" - то никто не виноват, показан УПРОЩЁННЫЙ пример.