问题
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?
回答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
来源：https://stackoverflow.com/questions/54827958/how-to-embed-a-gif-image-into-an-excel-file