Написать рессурс в коде - VBA

Формулировка задачи:

Мне нужно запихать картинку в код. Тобишь должна быть строка, в ней HEX данные картинки, а при записи этой строки в файл получалась бы эта картинка. Вот наброски кода:

Sub ShellExec()
    Dim f As Integer
    f = FreeFile
    Open ThisWorkbook.Path & "\image.jpg" For Output As f
    Print #f, HexToString("4d 5a 90 00 03")
    Close f

Проблема этого кода в том что поле в HexToString("") не бесконечно. В нем ограничение на определенную длинну. А мне нужно помещать данные порядка мегабайта в код.

Решение задачи: «Написать рессурс в коде»

textual
                            Листинг программы 
                        

                            Sub main()
 
    HomeDir$ = ThisWorkbook.Path
    fo$ = HomeDir$ + "\cat.jpg"  '::: имя созд. картинки
    Save_Pic Sheets(3), fo$, 1
    MsgBox "Картинка создана!"
 
End Sub
Sub test()
 
    HomeDir$ = ThisWorkbook.Path
    fi$ = HomeDir$ + "\cat-117.jpg"  '::: имя исх картинки
    r& = Load_pic(Sheets(3), fi$, 1)
    
    fo$ = HomeDir$ + "\cat.jpg"        '::: имя созд. картинки
    Save_Pic Sheets(3), fo$, 1
    
End Sub
 
Sub Save_Pic(Sh As Worksheet, fname As String, rbeg As Long)
    Lf& = Sh.Cells(rbeg, 1).Value
    Buf$ = Space$(Lf&)
    pp& = 1
    cc& = 2
    rr& = rbeg&
    Do
    
       Tmp$ = Trim$(Sh.Cells(rr&, cc&).Value)
       If Len(Tmp$) = 0 Then Exit Do
       V& = Val(Tmp$)
       kb& = IIf(Lf& - pp& > 3, 3, Lf& - pp&)
       If kb& = 0 Then Exit Do
       jj& = pp& + 2
       For i& = 1 To kb&
           a$ = Chr$(V& Mod 256)
           V& = V& \ 256
           Mid$(Buf$, jj&, 1) = a$
           jj& = jj& - 1
       Next i&
       pp& = pp& + 3
       If kb& < 3 Then Exit Do
       cc& = cc& + 1
       If cc& > 256 Then
          cc& = 1
          rr& = rr& + 1
       End If
    Loop
    For i& = 1 To kb&
        a$ = Chr$(V& Mod 256)
        V& = V& \ 256
        Mid$(Buf$, jj&, 1) = a$
        jj& = jj& - 1
    Next i&
    fo% = FreeFile
    Open fname For Binary Access Write As #fo%
    Put #fo%, , Buf$
    Close #fo%
End Sub
 
Function Load_pic(Sh As Worksheet, fname As String, rbeg As Long) As Long
    fi% = FreeFile
    Open fname For Binary Access Read As #fi%
    Lf& = LOF(fi%)
    Buf$ = Space$(Lf&)
    Get #fi%, , Buf$
    Close #fi%
    rr& = rbeg
    cc& = 1
    Sh.Cells(rr&, cc&).Value = Lf&
    cc& = 2
    V& = 0
    k% = 0
    For ii& = 1 To Lf&
        a& = Asc(Mid$(Buf$, ii&, 1))
        V& = V& * 256 + a&
        k% = k% + 1
        If k% = 3 Then
           Sh.Cells(rr&, cc&).Value = V&
           k% = 0
           V& = 0
           cc& = cc& + 1
           If cc& > 256 Then
              rr& = rr& + 1
              cc& = 1
           End If
        End If
    Next ii&
    If k% > 0 Then
       Sh.Cells(rr&, cc&).Value = V&
       cc& = cc& + 1
       If cc& > 256 Then rr& = rr& + 1
    End If
    Load_pic = rr&
End Function
                        