Ecel批量下载URL图片

hesengzu

想实现Excel批量下载URL图片，并自定义图片名称储存到指定文件夹

sunshuangzhong

Sub 借用网上大侠的下载图片()
Dim rng As Range, Cel As Range, xh, myPath, fn$, s() As Byte
Dim imageCol$, nameCol$
Set xh = CreateObject("MSXML2.XMLHTTP")
myPath = [b1].value
If Dir(myPath, vbDirectory) = "" Then MkDir myPath
nameCol = "A" '姓名所在列
imageCol = "B" '图所在列
For i = 2 To [a65536].End(xlUp).Row
    fn = myPath & "\" & Cells(i, nameCol).Value & ".jpg"
    If Dir(fn) = "" Then
        Set Cel = Cells(i, imageCol)
        'adr = Cel.Hyperlinks(1).Address
        adr = Cel.Value
        xh.Open "GET", adr, False
        xh.send
        s = xh.responsebody
        n = FreeFile
        Open fn For Binary As #n
            Put #n, , s
        Close #n
    End If
Next
End Sub

hesengzu

sunshuangzhong 发表于 2023-4-14 08:13
Sub 借用网上大侠的下载图片()
Dim rng As Range, Cel As Range, xh, myPath, fn$, s() As Byte
Dim imag ...

请大神，吧我的源文件直接写入VBA，然后传附件可以吗？ 我试了代码，但是说URL不可识别

tspliu

。。。。。。。。。。。。。。。。。。。什么都要审核

tspliu

发图片都要审核了吗？

hesengzu

tspliu 发表于 2023-4-14 09:17
发图片都要审核了吗？

大神，请把文件直接传上来让我下载行吗？

sunshuangzhong

运行正常运行正常运行正常运行正常

tspliu

hesengzu 发表于 2023-4-14 10:04
大神，请把文件直接传上来让我下载行吗？

什么都要审核。。。。。。。。。。。。。。。。。。。。。

tspliu

hesengzu 发表于 2023-4-14 10:04
大神，请把文件直接传上来让我下载行吗？

Sub main()
For i = 3 To 14
Debug.Print downImage(Cells(i, 2), Cells(i, 1))
DoEvents
Next
End Sub
Function downImage(Url, index$)
        On Error Resume Next
        Dim brr() As Byte
        Debug.Print Url
        Z = Split(Url, ".")
        Z = "." & Z(UBound(Z))
        If Url Like "https*.*" Then
             With CreateObject("msxml2.serverxmlhttp")
                .Open "get", Url, False
                .send
                Do Until .Status = 304 Or .Status = 200
                    DoEvents
                    If Timer - t >= 5 Then
                        brr = ""
                        GoTo 1
                    End If
                Loop
                    brr = .Responsebody

            End With

           writeImage [b1], brr, index & Z
           downImage = ThisWorkbook.path & "\mm\" & index & Z
        Else
1:
        downImage = "图片地址错误"
        End If

End Function
Private Sub writeImage(path$, arr() As Byte, index$)
    With CreateObject("scripting.filesystemobject")
        If Not .folderexists(path) Then
            .createfolder (path)
        End If
    End With
    Open path & "\" & index For Binary As #1
    Put #1, , arr
    Close #1
End Sub

perfect131

同步下载慢，改成 true，异步 就快了 ， 参考 7 楼
https://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1653722&pid=11187101