获取图片作为http GET响应并插入电子表格而不保存图片

Question

我正在使用以下代码从bing map网站获取图片并将其插入电子表格：

Public Sub Test()
    Dim FileNum As Long
    Dim myURL As String
    Dim FileData() As Byte
    Dim winHttpReq As Object
    Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")

    myURL = "..."

    winHttpReq.Open "GET", myURL, False
    winHttpReq.Send

    FileData = winHttpReq.ResponseBody

    FileNum = FreeFile
    Open "C:\Downloads\map.JPG" For Binary Access Write As #FileNum
    Put #FileNum, 1, FileData
    Close #FileNum

    InsertPic
End Sub

Sub InsertPic()
    Dim pic As String
    Dim myPicture As Picture

    pic = "C:\Downloads\map.JPG"
    Set myPicture = ActiveSheet.Pictures.Insert(pic)

    With myPicture
        .ShapeRange.LockAspectRatio = msoFalse
        .Top = ActiveSheet.Cells(33, 10).Top
        .Left = ActiveSheet.Cells(33, 10).Left
    End With
End Sub

有没有办法在不将图片保存在本地存储空间的情况下做同样的事情？

Answer 1

  

我只是说，因为我实际上并不需要存储我不喜欢的文件，除非我必须这样做。

我讨厌放弃！虽然我仍然觉得（正如我在上面的评论中提到的）将文件保存到用户的临时目录是一种简单易行的方法。事实上，我会为你提两种方法。

要测试此示例，请在Excel中创建用户表单。接下来，这样做。

1. 在其中放置TextBox，Image和Commandbutton控件。
2. 接下来添加inet控件。为此，您必须通过其他控件并设置对Microsoft Internet Transfer Control的引用。您的用户形式将如下所示。



接下来运行userform，然后在文本框中粘贴图像的URL。我正在使用http://static.freepik.com/free-photo/thumbs-up-smiley_17-1218174614.jpg

进行测试

单击命令按钮时，图像将填充在图像控件中。



<强>逻辑：

代码的作用是使用inet控件检索URL中的图像，然后将其存储在byte数组中（而不是您请求的目录）。然后，我将该字节数组转换为图像内存，然后将其分配给图像控件。

用户形式代码

Option Explicit

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" _
(ByRef hGlobal As Any, ByVal fDeleteOnResume As Long, ByRef ppstr As Any) As Long

Private Declare Function OleLoadPicture Lib "olepro32.dll" _
(ByVal lpStream As IUnknown, ByVal lSize As Long, ByVal fRunMode As Long, ByRef riid As GUID, ByRef lplpObj As Any) As Long

Private Declare Function CLSIDFromString Lib "ole32.dll" _
(ByVal lpsz As Long, ByRef pclsid As GUID) As Long

Private Const SIPICTURE As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

Dim boolSuccess As Boolean

Private Sub CommandButton1_Click()
    Dim URL As String
    Dim bytes() As Byte
    Dim ipic As IPictureDisp

    URL = TextBox1.Text

    '~~> Store the image from the url in a bytes array
    bytes() = Inet1.OpenURL(URL, icByteArray)

    '~~> Convert Byte Array into Image
    Set ipic = ImageFromByteAr(bytes)

    Image1.PictureSizeMode = fmPictureSizeModeStretch

    If boolSuccess = True Then
        '~~> Load Picture
        Image1.Picture = ipic
    Else
        MsgBox "Unable to convert to picture"
    End If
End Sub

Public Function ImageFromByteAr(ByRef byt() As Byte) As IPicture
    On Error GoTo Whoa

    Dim ippstr As IUnknown
    Dim tGuid As GUID

    If Not CreateStreamOnHGlobal(byt(LBound(byt)), False, ippstr) Then
        CLSIDFromString StrPtr(SIPICTURE), tGuid
        OleLoadPicture ippstr, UBound(byt) - LBound(byt) + 1, False, tGuid, ImageFromByteAr
    End If

    Set ippstr = Nothing

    boolSuccess = True
    Exit Function
Whoa:
    boolSuccess = False
End Function

---

这是方法2 （最简单的方法）

将文件保存到用户的临时目录

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

Public Sub Test()
    '
    '~~> Rest of your code
    '

    FileNum = FreeFile
    Open TempPath & "\map.JPG" For Binary Access Write As #FileNum

    '
    '~~> Rest of your code
    '
End Sub

Sub InsertPic()
    '
    '~~> Rest of your code
    '

    Dim pic As String
    Dim myPicture As Picture

    pic = TempPath & "\map.JPG"
    Set myPicture = ActiveSheet.Pictures.Insert(pic)

    '
    '~~> Rest of your code
    '
End Sub

Answer 2

如果您有网址，则：

Sub PictureGrabber()
    With ActiveSheet.Pictures
        .Insert ("http://www.cnn.com/whatever.jpg")
    End With
End Sub

编辑＃1 ：

对于使用winHttpReq的一些示例编码，请查看first function here

Answer 3

如果，WRT SiddharthRout的解决方案，您想要与64位Office兼容，那么就改变声明：

#If VBA7 Then
   Private Declare PtrSafe Function CreateStreamOnHGlobal Lib "OLE32.DLL" (ByRef hGlobal As Any, ByVal fDeleteOnResume As Long, ByRef ppstr As Any) As Long
   Private Declare PtrSafe Function OleLoadPicture Lib "oleaut32.dll" (ByVal lpStream As IUnknown, ByVal lSize As Long, ByVal fRunMode As Long, ByRef riid As GUID, ByRef lplpObj As Any) As Long
   Private Declare PtrSafe Function CLSIDFromString Lib "OLE32.DLL" (ByVal lpsz As LongPtr, ByRef pclsid As GUID) As Long
#Else
   Private Declare Function CreateStreamOnHGlobal Lib "OLE32.DLL" (ByRef hGlobal As Any, ByVal fDeleteOnResume As Long, ByRef ppstr As Any) As Long
   Private Declare Function OleLoadPicture Lib "olepro32.dll" (ByVal lpStream As IUnknown, ByVal lSize As Long, ByVal fRunMode As Long, ByRef riid As GUID, ByRef lplpObj As Any) As Long
   Private Declare Function CLSIDFromString Lib "OLE32.DLL" (ByVal lpsz As Long, ByRef pclsid As GUID) As Long
#End If

感谢Hans Passant。