如何将GIF图像嵌入Excel文件

通过ActiveX控件

MicrosoftWebBrowser

，我们可以在Excel的Web浏览器框中触发GIF文件的导航。为此，我定义了一个按钮，并为其分配了一个

宏

，该宏给出了要进行导航的GIF图像的本地地址（或链接）

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

有人知道Excel如何对GIF图像执行相同的操作吗？

复制自
如果不希望工作表中的数据，则可能需要将其移动到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"

测试方法：

；-）

选项显式
子测试（）
将文件名设置为字符串
'将图片保存到工作表十六进制字节数据。
Filename=“c:\temp\smiley.gif”
调用SaveAsHexFile（文件名）
'将文件还原到用户的临时目录。
Filename=RestoreHexFile
调试.打印文件名
'Filename now是还原文件的完整文件路径。
'将其传递给另一个宏或应用程序。
端接头
私有子SaveAsHexFile（ByVal文件名为字符串）
尺寸c与长度相同
将数据字节变为字节
Dim Data（）作为变量
我想我会坚持多久
作为整数的Dim n
变暗，变长
将工作作为工作表
将x作为字符串
如果Dir（Filename）=“”，则
MsgBox“未找到文件”&“未找到文件名”
出口接头
如果结束
出错时继续下一步
设置Wks=工作表（“十六进制字节数据”）
如果Err=9，则
Worksheets.Add After:=Worksheets.Count
设置Wks=ActiveSheet
Wks.Name=“十六进制字节数据”
如果结束
错误转到0
Wks.Cells.ClearContents
Wks.Cells（1，“AH”）.Value=Dir（文件名）
n=自由文件
Application.ScreenUpdating=False
Application.ErrorCheckingOptions.NumberAsText=False
带Wks.Columns（“A:AF”）
.NumberFormat=“@”
.Cells.HorizontalAlignment=xlCenter
打开二进制访问的文件名，读取为#n
ReDim数据（（LOF（n）-1）\32,31）
对于i=0到LOF（n）-1
获取#n，数据字节
c=i模32
r=i\32
x=十六进制（数据字节）
如果数据字节<16，则x=“0”&x
数据（r，c）=x
接下来我
关闭#n
Wks.Range（“A1:AF1”）。调整大小（r+1,32）。值=数据
.列（“A:AF”）.自动拟合
以
Application.ScreenUpdating=True
端接头
函数RestoreHexFile（）作为字符串
暗淡单元格作为范围
Dim Data（）作为字节
将文件设置为字符串
Dim j尽可能长
变光LSB
作为变量的Dim MSB
作为整数的Dim n
变暗Rng As范围
将工作作为工作表
出错时继续下一步
设置Wks=工作表（“十六进制字节数据”）
如果错误为0，则
MsgBox“缺少工作表‘十六进制字节数据’”，vbCritical
退出功能
如果结束
错误转到0
设置Rng=Wks.Range（“A1”）.CurrentRegion
File=Wks.Cells（1，“AH”）.Value
File=Replace（文件“.”、“\u NEW.”）
如果文件“”那么
n=自由文件
File=Environ（“TEMP”）和“\”文件
以#n的形式打开二进制访问写入文件
ReDim数据（应用程序计数（Rng）-1）
对于Rng中的每个单元
如果单元格=”，则退出以获取
MSB=左侧（单元格，1）
如果是数字（MSB），则MSB=16*MSB，否则MSB=16*（Asc（MSB）-55）
LSB=右侧（单元格，1）
如果不是IsNumeric（LSB），那么LSB=（Asc（LSB）-55）否则LSB=LSB*1
数据（j）=MSB+LSB
j=j+1
下一个细胞
放#n，数据
关闭#n
如果结束
RestoreHexFile=File
端函数

我一直相信Excel中的一切都是可能的。非常感谢分享：）我也感谢你提到的链接的作者。

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