|
- Sub DLFAST()
- Dim Url, Path As String
- Dim BL As Boolean
-
- Dim T
- T = Timer '//开始时间
-
- Url = "https://img.alicdn.com/bao/uploaded/i4/366168649/O1CN01LSxwOs2DlIHFS04ss_!!0-item_pic.jpg"
- Path = ThisWorkbook.Path & "\590919202992"
-
- For I = 1 To 100 '0.4 秒
- BL = DownloadWebFile(Url, Path)
- Next
- MsgBox "一共用时:" & Format(Timer - T, "#0.0000") & " 秒", vbInformation, "北极狐QQ:14885553" '//提示所用时间
- End Sub
- Public Function DownloadWebFile(ByVal ImageUrl As String, ByVal SavePath As String) As Boolean
- Rem 函数 将网络文件下载到本地 极速版本
- Rem ImageURl 下载的文件地址
- Rem SavePath 存储的磁盘位置,绝对路径 可以不带扩展名
- Rem 使用方法: BL = DownloadWebFile(Url, Path)
-
- Dim FSO
- Dim HTTP As Object
- Dim Bytes() As Byte
- Dim Tmp1, Tmp2, ExName As String
- Dim X As Long
-
- Rem 禁止系统刷屏?触发其他事件等
- On Error Resume Next '// 发生错误,自动执行下一句,就是忽略错误
- Err.Clear
- Rem 访问网络文件地址
- Set HTTP = CreateObject("Microsoft.XMLHTTP")
- HTTP.Open "GET", ImageUrl, False
- HTTP.send
-
- Rem 如果地址连接OK
- If HTTP.Status = 200 Then
- Rem 处理扩展名 保存路径可能没有扩展名
- X = InStrRev(SavePath, ".")
- If X > 0 And (Len(SavePath) - X) <= 5 Then
- ExName = "" '//自带扩展名
- Else
- Rem 获取扩展名
- Tmp1 = Split(ImageUrl, "=")
- Tmp2 = Split(Tmp1(UBound(Tmp1)), ".")
- ExName = Tmp2(UBound(Tmp2)) '从网址获取内容扩展名(不仅仅限于图片了 ^_^)
- If Len(ExName) > 4 Or Len(ExName) = 0 Then
- ExName = ".jpg" '无法获得扩展名时,默认为.jpg
- Else
- ExName = "." & ExName
- End If
- End If
- Bytes = HTTP.responseBody
- Open SavePath & ExName For Binary As #1 '二进制形式写入文件
- Put 1, , Bytes
- Close #1
- End If
- Rem 输出结果
- If Err.Number = 0 Then
- Set FSO = CreateObject("Scripting.FileSystemObject")
- DownloadWebFile = FSO.FileExists(SavePath)
- Else
- Rem MsgBox "函数: DownloadWebFile 出错" & vbCrLf & vbCrLf & Err.Description
- DownloadWebFile = False
- End If
- End Function
复制代码
|
评分
-
3
查看全部评分
-
|