Excel VBA：網(wǎng)抓+自定義函數(shù)+字典+FSO批量將網(wǎng)絡(luò)圖片保存到本地 詳細(xì)
本視頻代碼：
Sub 將一張圖片保存到本地()
??Dim XmlHttp As Object
??Dim url As String
??Dim 二進(jìn)制數(shù)據(jù)() As Byte
??Dim fullName As String
???
??Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
???
??url = "https://gw.alicdn.com/bao/uploaded/i4/3327042818/O1CN01Q7ZvQM1WggvKjZWii_!!3327042818.png_110x10000.jpg_.webp"
???
??With XmlHttp
????.Open "GET", url, False
????.Send
?????
????Do While .readyState <> 4
??????DoEvents
????Loop
?????
????二進(jìn)制數(shù)據(jù) = .responseBody
?????
????fullName = "E:\資料\學(xué)習(xí)\答疑\VBA\20230711網(wǎng)抓方式批量存圖\結(jié)果\1.webp"
?????
????'將圖片的二進(jìn)制內(nèi)容寫(xiě)入到本地（文件）
????Open fullName For Binary As #1
?????
????'Write #1, "abcd"
????'Print #1, "ABCD"
????Put #1, , 二進(jìn)制數(shù)據(jù)
?????
????Close #1
??End With
End Sub
Sub 遍歷有效網(wǎng)址()
??Dim t0 As Single: t0 = Timer
??Dim arr
??Dim i As Long
??Dim j As Long
??Dim url As String
??Dim XmlHttp As Object
??Dim 二進(jìn)制數(shù)據(jù)() As Byte
??Dim fullName As String
??Dim dict As Object
??Dim key As String
??Dim fileName As String
??Dim fso As Object
??Dim extName As String
???
??Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
??Set dict = CreateObject("Scripting.Dictionary")
??Set fso = CreateObject("Scripting.FileSystemObject")
???
??arr = ThisWorkbook.Sheets("表1").Range("A1").CurrentRegion.Value
???
??For i = LBound(arr, 1) + 1 To UBound(arr, 1)
????For j = LBound(arr, 2) + 1 To UBound(arr, 2)
??????url = arr(i, j)
??????url = 純文本(url)
??????If Not url = "" Then
????????Debug.Print url
?????????
????????With XmlHttp
??????????.Open "GET", url, False
??????????.Send
???????????
??????????Do While .readyState <> 4
????????????DoEvents
??????????Loop
???????????
??????????二進(jìn)制數(shù)據(jù) = .responseBody
???????????
??????????key = arr(i, 1)
??????????key = 純文本(key)
???????????
??????????If Not dict.Exists(key) Then
????????????dict(key) = 1
??????????Else
????????????dict(key) = dict(key) + 1
??????????End If
???????????
??????????fileName = key & "_" & dict(key)
???????????
??????????extName = fso.GetExtensionName(url)
???????????
??????????fullName = "E:\資料\學(xué)習(xí)\答疑\VBA\20230711網(wǎng)抓方式批量存圖\結(jié)果\" & fileName & "." & extName
??????????Debug.Print fullName
???????????
??????????'將圖片的二進(jìn)制內(nèi)容寫(xiě)入到本地（文件）
??????????Open fullName For Binary As #1
??????????'Write #1, "abcd"
??????????'Print #1, "ABCD"
??????????Put #1, , 二進(jìn)制數(shù)據(jù)
??????????Close #1
????????End With
??????End If
????Next j
??Next i
???
??Set XmlHttp = Nothing
??Set dict = Nothing
??Set fso = Nothing
???
??MsgBox Format(Timer - t0, "完成，用時(shí)0.000秒！")
End Sub
Sub 批量將網(wǎng)絡(luò)圖片保存到本地()
??Dim arr
??Dim i As Long
??Dim j As Long
??Dim url As String
???
??arr = ThisWorkbook.Sheets("表1").Range("A1").CurrentRegion.Value
???
??For i = 2 To 9
????For j = 2 To 3
??????url = arr(i, j)
??????url = 純文本(url)
??????If Not url = "" Then
????????Debug.Print url
??????End If
????Next j
??Next i
End Sub
Function 純文本(原始文本) As String
??Dim s As String
???
??s = 原始文本
??'s = Trim(s)
??s = Replace(s, " ", "")
??s = Replace(s, " ", "")
??s = Replace(s, vbTab, "")
??s = Replace(s, Chr(7), "")
??s = Replace(s, Chr(10), "")
??s = Replace(s, Chr(11), "")
??s = Replace(s, Chr(13), "")
??s = Replace(s, ChrW(160), "")
???
??純文本 = s
End Function
