Как вставить изображение GIF в файл Excel

Question

С помощью элемента управления ActiveX Microsoft Web-browser мы можем запустить навигацию по GIF-файлу в окне веб-браузера в Excel.Я делаю это, определяя кнопку и назначая ей macro, которая дает локальный адрес (или ссылку) этого изображения GIF для навигации, которая будет выполнена.

Проблема с этим заключается в том, чтобыИспользуйте такой файл Excel для презентации, вы должны также нести файл GIF на любом компьютере, который будет запущен.Когда мы вставляем изображение в файл Excel, оно будет встроено в него, и нет необходимости переносить файл реального изображения, например формат PNG, чтобы Excel мог распознать, что показывать.

Кто-нибудь знает, как Excel может вести себя так же для изображений GIF?

Answer 1

Скопировано из http://www.vbaexpress.com/forum/showthread.php?55713-Store-image-in-VBA
Если вам не нужны данные на рабочем листе, вы можете переместить их в vba и написать необходимый код преобразования.

Если код работает для вас,Вы можете оставить автору кода «спасибо» на указанном выше сайте!

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"

протестировано с:

; -)

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