使用Excel vba，將網絡圖像保存到磁盤

Question

我試圖使用excel vba從網頁保存圖像。 我設法得到字符串（雖然不是我想要的），並且需要將其保存到磁盤。

爲源的HTML代碼是：

<img id="SkuPageMainImg" data-sku="491215" alt="Papir ubleket kraft 60g 40cm 5kg/rull" class="skuImageSTD" src="/content/images/product/491215_1_xnm.jpg?v=4TWLBni1V4k8GV8B_0P-GA" data-zoomimage="//www.staples.no/content/images/product/491215_1_xnl.jpg" data-resizeimage="{&quot;0to1024&quot;:&quot;/content/images/product/491215_1_xnm.jpg?v=4TWLBni1V4k8GV8B_0P-GA&quot;,&quot;1025to1450&quot;:&quot;//www.staples.no/content/images/product/491215_1&quot;}" data-screensize=""> 

我的代碼是：IMG = .document.getElementById("SkuPageMainImg").src

此代碼捕獲src=後的網址：

/content/images/product/491215_1_xnm.jpg?v=4TWLBni1V4k8GV8B_0P-GA" 

這會做些什麼，而我會主張追捕data-zoomimage=： "//www.staples.no/content/images/product/491215_1_xnl.jpg"

無論哪種方式，我所希望實現的是有Excel的VBA將圖像保存到一個文件我的硬盤上 - 通常c:\folder\image_name.jpg

有人知道代碼做到這一點？

Answer 1

導入URLDownloadToFile函數並直接使用它。以下是整個模塊代碼表，其中包括頂部的聲明部分。該例程預計柱充分IMG SRC URL列表的起始處第2行例如爲：http://www.staples.no/content/images/product/491215_1_xnm.jpg

Option Explicit 

#If VBA7 And Win64 Then 
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _ 
     Alias "URLDownloadToFileA" (_ 
     ByVal pCaller As LongPtr, _ 
     ByVal szURL As String, _ 
     ByVal szFileName As String, _ 
     ByVal dwReserved As LongPtr, _ 
     ByVal lpfnCB As LongPtr _ 
    ) As Long 
    Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _ 
     Alias "DeleteUrlCacheEntryA" (_ 
     ByVal lpszUrlName As String _ 
    ) As Long 
#Else 
    Private Declare Function URLDownloadToFile Lib "urlmon" _ 
     Alias "URLDownloadToFileA" (_ 
     ByVal pCaller As Long, _ 
     ByVal szURL As String, _ 
     ByVal szFileName As String, _ 
     ByVal dwReserved As Long, _ 
     ByVal lpfnCB As Long _ 
    ) As Long 
    Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _ 
     Alias "DeleteUrlCacheEntryA" (_ 
     ByVal lpszUrlName As String _ 
    ) As Long 
#End If 

Public Const ERROR_SUCCESS As Long = 0 
Public Const BINDF_GETNEWESTVERSION As Long = &H10 
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000 

Sub dlStaplesImages() 
    Dim rw As Long, lr As Long, ret As Long, sIMGDIR As String, sWAN As String, sLAN As String 

    sIMGDIR = "c:\folder" 
    If Dir(sIMGDIR, vbDirectory) = "" Then MkDir sIMGDIR 

    With ActiveSheet '<-set this worksheet reference properly! 
     lr = .Cells(Rows.Count, 1).End(xlUp).Row 
     For rw = 2 To lr 

      sWAN = .Cells(rw, 1).Value2 
      sLAN = sIMGDIR & Chr(92) & Trim(Right(Replace(sWAN, Chr(47), Space(999)), 999)) 

      Debug.Print sWAN 
      Debug.Print sLAN 

      If CBool(Len(Dir(sLAN))) Then 
       Call DeleteUrlCacheEntry(sLAN) 
       Kill sLAN 
      End If 

      ret = URLDownloadToFile(0&, sWAN, sLAN, BINDF_GETNEWESTVERSION, 0&) 

      .Cells(rw, 2) = ret 
      Next rw 
    End With 

End Sub 

0值是B列表示成功（例如ERROR_SUCCESS）。