如何将GIF图像嵌入Excel文件

Question

通过ActiveX控件Microsoft Web-browser，我们可以在Excel中的web浏览器框中触发GIF文件的导航。为此，我定义了一个按钮，并将一个macro分配给它，为导航提供了该GIF图像的本地地址(或链接)。

这方面的问题是，为了使用这样一个excel文件作为演示，您也必须携带GIF文件在任何计算机上，它将被启动。当我们将图像插入到Excel文件中时，它将被嵌入其中，并且不需要携带真实的图像文件--例如Excel的PNG格式--才能识别要显示的内容。

有没有人知道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