|
Функция FileToVBAFunction предназначена для сохранения произвольного файла в виде VBA кода.
В любой момент вы можете вызвать сгенерированную функцию - она моментально создаст во временной папке необходимый файл, и вернет путь к созданному файлу.
Основное применение функции - сохранение небольших файлов (в основном, графических - иконок и маленьких картинок) в книге Excel.
Для того, чтобы прикрепить большие файлы к книге Excel, или если надо управлять вложенными файлами,
воспользуйтесь универсальным решением на базе модулей класса
При необходимости, такой файл в любой момент можно извлечь, просто вызвав созданную функцию.
Примеры использования функции FileToVBAFunction:
Sub ПримерИспользования_FileToVBAFunction()
' преобразовываем заданный файл в VBA функцию
txt$ = FileToVBAFunction("D:\Distr\аватары\joda.jpg", "joda")
' выводим созданную функцию в окно Immediate
Debug.Print txt$
End Sub
Sub Выбрать_Файл_и_Скопировать_Его_в_Виде_Кода_VBA_в_Буфер_Обмена()
' выводим диалоговое окно выбора файла
filename = Application.GetOpenFilename("Любые файлы небольшого размера (*.*),", , _
"Выберите файл для загрузки в проект VBA", "Загрузить")
If VarType(filename) = vbBoolean Then Exit Sub ' пользователь отказался от выбора файла
' преобразовываем заданный файл в VBA функцию
txt$ = FileToVBAFunction(filename, "MyFile")
' копируем полученный код VBA-функции в буфер обмена
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText txt$
.PutInClipboard
End With
End Sub
Запустив второй макрос (копирующий код созданной фунции в буфер обмена),
и вставив результат из буфера обмена в стандартный модуль VBA,
мы получим готовую функцию для создания файла примерно такого вида:
Строки, содержащие данные файла, получаются очень длинные (около 1000 символов),
но зато количество строк в созданной функции обычно невелико, если мы таким образом прикрепляем к файлу Excel небольшие файлы и картинки.
Поскольку в одной строке кода VBA мы можем сохранить около 500 байтов информации,
функция для создания, к примеру, 20-килобайтного файла, будет содержать около 50 строк кода
(около 40 строк с данными + 10 служебных строк, преобразовывающих эти данные в реальный файл)
Код функции FileToVBAFunction:
Private Function FileToVBAFunction(ByVal filename$, Optional ByVal name$ = "noname") As String
On Error Resume Next: Err.Clear: Const BYTES_PER_ROW& = 480
Dim F_Content$
ff& = FreeFile: Open filename$ For Binary Access Read As #ff
FS& = LOF(ff): txt$ = String(FS&, Chr(0))
Get #ff, , txt$: Close #ff
F_Content$ = F_Content$ & "Function GetFile_" & name$ & "() As String" & vbNewLine
F_Content$ = F_Content$ & "' создаёт во временной папке файл, возвращает путь к созданному файлу" & vbNewLine
F_Content$ = F_Content$ & "On Error Resume Next: Dim F_TXT$, buf$, tmp_file$: Const BufLen& = 5000" & vbNewLine
For i = 1 To Len(txt$)
r& = Asc(Mid(txt, i, 1))
res$ = res$ & IIf(Len(Hex(r)) = 1, "0", "") & Hex(r)
If i Mod BYTES_PER_ROW& = 0 Then
F_Content$ = F_Content$ & "F_TXT$ = F_TXT$ & """ & res$ & """" & vbNewLine
res = "": DoEvents
End If
Next
If Len(res) Then F_Content$ = F_Content$ & "F_TXT$ = F_TXT$ & """ & res$ & """" & vbNewLine
F_Content$ = F_Content$ & "For i = 1 To Len(F_TXT$) / 2" & vbNewLine
F_Content$ = F_Content$ & "buf$ = buf$ & Chr(Val(""&H"" & Mid(F_TXT$, 2 * i - 1, 2)))" & vbNewLine
F_Content$ = F_Content$ & "If Len(buf$) > BufLen& Then res$ = res$ & buf$: buf$ = """": DoEvents" & vbNewLine
F_Content$ = F_Content$ & "Next: res$ = res$ & buf$" & vbNewLine
F_Content$ = F_Content$ & "tmp_file$ = Environ(""tmp"") & ""\file_" & name$ & """ : Kill tmp_file$" & vbNewLine
F_Content$ = F_Content$ & "ff& = FreeFile: Open tmp_file$ For Binary Access Write As #ff" & vbNewLine
F_Content$ = F_Content$ & "Put #ff, , res$" & vbNewLine
F_Content$ = F_Content$ & "Close #ff" & vbNewLine
F_Content$ = F_Content$ & "If FileLen(tmp_file$) = Len(F_TXT$) / 2 Then GetFile_" & name$ & " = tmp_file$" & vbNewLine
F_Content$ = F_Content$ & "End Function" & vbNewLine
FileToVBAFunction = F_Content$
End Function
|
