How to embed a GIF image into an Excel file

Question

Through ActiveX Control Microsoft Web-browser, we can trigger the navigation of a GIF file within a web browser box in Excel. I do this by defining a button and assigning a macro to it which gives the local address (or link) of that GIF image for the navigation to be done.

The problem with this is, in order to use such an excel file for presentation, you have to carry the GIF file too on any computer its going to be launched. While when we insert an image into an Excel file, it will be embedded into it and there is no need to carry the real image file for instance the PNG format for the Excel to be able to recognize what to show.

Does anyone have any clue how Excel can behave the same for GIF images?

Answer 1

Copied from http://www.vbaexpress.com/forum/showthread.php?55713-Store-image-in-VBA
If you don't want the data on a worksheet you might want to move it to vba and write the necessary conversion code.

If the code works for you, you might leave the author of the code a "thank you" on the site mentioned above!

dim pic(1000) as string
pic(1)="47 49 46 38 39 61 F0 00 F0 00 F7 86 00 00 00 ... CD 1B 53"

tested with:

;-)

Option Explicit
Sub Test()
    Dim Filename As String
      ' Save picture to the worksheet Hex Byte Data.
        Filename = "c:\temp\smiley.gif"
        Call SaveAsHexFile(Filename)

      ' Restore the file to the user's Temp directory.
        Filename = RestoreHexFile
        Debug.Print Filename

      ' Filename now is the complete file path to the restored file.
      ' Pass this to another macro or application.
End Sub

Private Sub SaveAsHexFile(ByVal Filename As String)
    Dim c        As Long
    Dim DataByte As Byte
    Dim Data()   As Variant
    Dim i        As Long
    Dim n        As Integer
    Dim r        As Long
    Dim Wks      As Worksheet
    Dim x        As String

        If Dir(Filename) = "" Then
            MsgBox "The File '" & Filename & "' Not Found."
            Exit Sub
        End If

        On Error Resume Next
            Set Wks = Worksheets("Hex Byte Data")
            If Err = 9 Then
                Worksheets.Add After:=Worksheets.Count
                Set Wks = ActiveSheet
                Wks.Name = "Hex Byte Data"
            End If
        On Error GoTo 0

        Wks.Cells.ClearContents
        Wks.Cells(1, "AH").Value = Dir(Filename)

        n = FreeFile

        Application.ScreenUpdating = False
        Application.ErrorCheckingOptions.NumberAsText = False

            With Wks.Columns("A:AF")
                .NumberFormat = "@"
                .Cells.HorizontalAlignment = xlCenter

                Open Filename For Binary Access Read As #n
                    ReDim Data((LOF(n) - 1) \ 32, 31)

                    For i = 0 To LOF(n) - 1
                        Get #n, , DataByte
                        c = i Mod 32
                        r = i \ 32
                        x = Hex(DataByte)
                        If DataByte < 16 Then x = "0" & x
                        Data(r, c) = x
                    Next i
                Close #n

                Wks.Range("A1:AF1").Resize(r + 1, 32).Value = Data
                .Columns("A:AF").AutoFit
            End With

        Application.ScreenUpdating = True

End Sub

Function RestoreHexFile() As String

    Dim Cell    As Range
    Dim Data()  As Byte
    Dim File    As String
    Dim j       As Long
    Dim LSB     As Variant
    Dim MSB     As Variant
    Dim n       As Integer
    Dim Rng     As Range
    Dim Wks     As Worksheet

        On Error Resume Next
            Set Wks = Worksheets("Hex Byte Data")
            If Err <> 0 Then
                MsgBox "The Worksheet 'Hex Byte Data' is Missing.", vbCritical
                Exit Function
            End If
        On Error GoTo 0

        Set Rng = Wks.Range("A1").CurrentRegion

        File = Wks.Cells(1, "AH").Value
        File = Replace(File, ".", "_NEW.")

        If File <> "" Then
            n = FreeFile
            File = Environ("TEMP") & "\" & File

            Open File For Binary Access Write As #n
                ReDim Data(Application.CountA(Rng) - 1)

                For Each Cell In Rng
                    If Cell = "" Then Exit For

                    MSB = Left(Cell, 1)
                    If IsNumeric(MSB) Then MSB = 16 * MSB Else MSB = 16 * (Asc(MSB) - 55)

                    LSB = Right(Cell, 1)
                    If Not IsNumeric(LSB) Then LSB = (Asc(LSB) - 55) Else LSB = LSB * 1

                    Data(j) = MSB + LSB
                    j = j + 1
                Next Cell

                Put #n, , Data
            Close #n
        End If
       RestoreHexFile = File
End Function