Импорт файла в проект VBA - формирование функции VBA, создающей файл

Функция 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,
мы получим готовую функцию для создания файла примерно такого вида:

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$

Без этого, код отрабатывал не всегда. После исправления, вроде стабильно работает.

спасибо большое
вот пытаюсь разобраться,
итоговая функция не возвращает строку,
в качестве параметра, в идеале можно было бы указать место куда извлекать

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _        __     _____   ____    __  __     _ 
| | / /_ |___ | / ___| | \/ | (_)
| | | '_ \ / / \___ \ | |\/| | | |
| |___ | (_) | / / ___) | | | | | | |
|_____| \___/ /_/ |____/ |_| |_| _/ |
|__/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.