Функция 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
Комментарии
Супер "тема" - именно что-то подобное искал. Спасибо автору!
вообще я подал идею полезного макроса, работающего на том же принципе, но для других целей
есть много общего, поэтому решил написать тут
никакой критики с моей стороны тут нет
удалите, если не нравится
Risagitov, мне одному кажется, что ваш комментарий не имеет никакого отношения к макросу, описанному в статье?
очень хороший макрос, но думаю макрос сохраняющий структуру таблицы в процедуре, был бы более полезен
то есть запускаю макрос, он просит выделить диапазон ячеек в листе,
я выделяю то место, где шапка таблицы (обычно у нее сложная структура)
, далее нажимаю ок
все, макрос создан и записан в буффер,
далее его нужно просто вставить и пользоваться
как пользоваться?
например на листе кнопка "восстановить шапку таблицы"
нажимаю ее и таблица восстанавливается
Попробуйте обновленный вариант функции - я добавил в одну строку создаваемого макроса предварительное удаление старого файла перед созданием:
Kill tmp_file$
Без этого, код отрабатывал не всегда. После исправления, вроде стабильно работает.
спасибо большое
вот пытаюсь разобраться,
итоговая функция не возвращает строку,
в качестве параметра, в идеале можно было бы указать место куда извлекать
Отправить комментарий