根据URL下载网络图片

opiona

1. 
   
2. Sub DLFAST()
   
3.     Dim Url, Path As String
   
4.     Dim BL As Boolean
   
5.    
   
6.     Dim T
   
7.     T = Timer   '//开始时间
   
8.    
   
9.     Url = "https://img.alicdn.com/bao/uploaded/i4/366168649/O1CN01LSxwOs2DlIHFS04ss_!!0-item_pic.jpg"
   
10.     Path = ThisWorkbook.Path & "\590919202992"
    
11.    
    
12.     For I = 1 To 100   '0.4 秒
    
13.         BL = DownloadWebFile(Url, Path)
    
14.     Next
    
15.     MsgBox "一共用时：" & Format(Timer - T, "#0.0000") & " 秒", vbInformation, "北极狐QQ：14885553" '//提示所用时间
    
16. End Sub
    
17. 
    
18. Public Function DownloadWebFile(ByVal ImageUrl As String, ByVal SavePath As String) As Boolean
    
19.     Rem 函数            将网络文件下载到本地 极速版本
    
20.     Rem ImageURl   下载的文件地址
    
21.     Rem SavePath    存储的磁盘位置，绝对路径  可以不带扩展名
    
22.     Rem 使用方法:   BL = DownloadWebFile(Url, Path)
    
23.    
    
24.     Dim FSO
    
25.     Dim HTTP As Object
    
26.     Dim Bytes() As Byte
    
27.     Dim Tmp1, Tmp2, ExName As String
    
28.     Dim X As Long
    
29.    
    
30.     Rem 禁止系统刷屏?触发其他事件等
    
31.     On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    
32.     Err.Clear
    
33.     Rem 访问网络文件地址
    
34.     Set HTTP = CreateObject("Microsoft.XMLHTTP")
    
35.     HTTP.Open "GET", ImageUrl, False
    
36.     HTTP.send
    
37.    
    
38.     Rem 如果地址连接OK
    
39.     If HTTP.Status = 200 Then
    
40.         Rem 处理扩展名 保存路径可能没有扩展名
    
41.         X = InStrRev(SavePath, ".")
    
42.         If X > 0 And (Len(SavePath) - X) <= 5 Then
    
43.             ExName = ""   '//自带扩展名
    
44.         Else
    
45.             Rem  获取扩展名
    
46.             Tmp1 = Split(ImageUrl, "=")
    
47.             Tmp2 = Split(Tmp1(UBound(Tmp1)), ".")
    
48.             ExName = Tmp2(UBound(Tmp2))                '从网址获取内容扩展名（不仅仅限于图片了 ^_^）
    
49.             If Len(ExName) > 4 Or Len(ExName) = 0 Then
    
50.                 ExName = ".jpg"     '无法获得扩展名时，默认为.jpg
    
51.             Else
    
52.                 ExName = "." & ExName
    
53.             End If
    
54.         End If
    
55. 
    
56.         Bytes = HTTP.responseBody
    
57.         Open SavePath & ExName For Binary As #1   '二进制形式写入文件
    
58.         Put 1, , Bytes
    
59.         Close #1
    
60.     End If
    
61.     Rem 输出结果
    
62.     If Err.Number = 0 Then
    
63.       Set FSO = CreateObject("Scripting.FileSystemObject")
    
64.     DownloadWebFile = FSO.FileExists(SavePath)
    
65.     Else
    
66.         Rem  MsgBox "函数: DownloadWebFile 出错" & vbCrLf & vbCrLf & Err.Description
    
67.         DownloadWebFile = False
    
68.     End If
    
69. End Function

复制代码