一、ieobject
二、CreateObject("InternetExplorer.Application")
三、web 查詢
四、直接用網址插入網頁圖片
五、其它…等等
常常會造成excel 停止回應一下子
匯入圖片反應很慢，速度不穩定，一張圖2秒~1分鐘
嚴重的話excel還會當掉
雖然簡單，但只適合“固定圖片名稱”的網頁
不適合用在一直在變動的圖片資料，名稱一變，連結就失效
但如果先下載再插入就可避免這個問題
這個範例就是使用 xmlhttp 快速取得網頁上所有的純圖片網址
下載全部圖片後再插入excel表格，不需開ie、不用ieobject
可以用非常快的速度在excel中插入網頁的圖片
這個網頁16張圖(如果google facebook那2張也算進來)
用這個方式，下載+插入圖片，大約只要 1.2秒
範例網站：
台灣股市資訊網 http://goodinfo.tw/StockInfo/index.asp
股票代號：2412 (紅圈內的所有圖片)
http://goodinfo.tw/StockInfo/StockDetail.asp?STOCK_ID=2412
'====程式碼要放在“模組”裡====
'使用urlmon函式庫
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
Sub getimage()
ttt = Timer
Dim Url, Url_a, HTMLsourcecode, XMLGET, ImageLinks, links, ImageFiles, target, Del_Image As Shape
target = "c:\excel\"
If Dir(target, vbDirectory) = "" Then
'建立暫存目錄
MkDir target
Else
'刪除暫存目錄內所有檔案
'注意，目錄內所有檔案，會在無任何提示下刪除，請小心設定目錄名稱、位置
If Dir(target & "*.*") <> "" Then Kill target & "*.*"
'刪除sheet1裡面，已插入的所有圖片
For Each Del_Image In Sheets("sheet1").Shapes
If Del_Image.Type = 11 Then Del_Image.Delete
Next
End If
Set HTMLsourcecode = CreateObject("htmlfile")
Set XMLGET = CreateObject("WinHttp.WinHttpRequest.5.1")
Url = "http://goodinfo.tw/StockInfo/StockDetail.asp?STOCK_ID=2412"
Url_a = "http://goodinfo.tw/StockInfo/"
With XMLGET
.Open "GET", Url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.send
HTMLsourcecode.body.innerhtml = convertraw(.responsebody)
'把所有圖片網址，設成一個物件
Set ImageLinks = HTMLsourcecode.all.tags("image")
For Each links In ImageLinks
i = i + 1
'下載網頁內所有的圖片
URLDownloadToFile 0, Url_a & Replace(links.href, "about:", ""), target & i & ".gif", 0, 0
Set ImageFiles = Sheets("sheet1").Pictures.Insert(target & i & ".gif")
'插入圖片，調整位置
With ImageFiles
.Left = ActiveSheet.Cells((i - 1) * 10 + 1, 2).Left
.Top = ActiveSheet.Cells((i - 1) * 10 + 1, 2).Top
End With
Next
End With
Set HTMLsourcecode = Nothing
Set XMLGET = Nothing
Set ImageLinks = Nothing
Set ImageFiles = Nothing
Debug.Print Timer - ttt
End Sub
Function convertraw(rawdata)
Dim rawstr
Set rawstr = CreateObject("adodb.stream")
With rawstr
.Type = 1
.Mode = 3
.Open
.Write rawdata
.Position = 0
.Type = 2
.Charset = "utf-8"
convertraw = .ReadText
.Close
End With
Set rawstr = Nothing
End Function
'===========================================
如果，不想下載全部圖片，只要把這9行程式碼刪掉
For Each links In ImageLinks
...
next
例如只要網頁中16張圖片的圖片3(google facebook 是圖片1、圖片2)
程式碼改成
URLDownloadToFile 0, Url_a & Replace(ImageLinks(3).href, "about:", ""), target & "temp.gif", 0, 0
Set ImageFiles = Sheets("sheet1").Pictures.Insert(target & "temp.gif")
With ImageFiles
.Left = ActiveSheet.Cells(2, 2).Left
.Top = ActiveSheet.Cells(2, 2).Top
End With
這個範例也可以合併到21樓的範例中
美觀方面請自行加程式碼處理
附加壓縮檔: 201804/mobile01-bc495fc8173a47886cb6c1869ac7a8fa.zip
