2

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

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

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

4

3 回答 3

4

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

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

要测试此示例，请在 Excel 中创建一个用户窗体。接下来，执行此操作。

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

在此处输入图像描述

接下来运行用户表单，然后将图像的 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
于 2013-11-12T17:53:20.473 回答
2

如果您有 URL，则：

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

编辑＃1：

有关使用 winHttpReq 的一些示例编码，请在此处查看第一个函数

于 2013-11-12T15:54:02.580 回答
1

如果，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

感谢汉斯·帕桑特。

于 2016-09-09T10:52:05.490 回答