从图片链接中，批量下载图片并更名

sinoshon

B列为图片的超级链接，将B列的图片下载到此工作薄所在的文件夹下，并用C列的文件名称保存。请见样列！

求高高手帮写一个串VBA，谢谢！

phsu

Sub DownLoadPics()
  Dim myIE
  Dim i As Integer
  Dim nRow As Integer
  Set myIE = CreateObject("Msxml2.XMLHTTP")
  With Worksheets("Sheet1")
    nRow = .Range("A65536").End(xlUp).Row
    For i = 2 To nRow
      If .Range("B" & i) <> "" Then
        myIE.Open "GET", .Range("B" & i), False
        myIE.Send
        Do Until myIE.ReadyState = 4
          DoEvents
        Loop
        With CreateObject("ADODB.Stream")
          .Type = 1
          .Open
          .write myIE.Responsebody
          .savetofile ThisWorkbook.Path & "\" & Worksheets("Sheet1").Range("C" & i), 2
          .Close
        End With
      End If
    Next
  End With
End Sub

sinoshon

phsu 发表于 2015-4-6 12:35
Sub DownLoadPics()
  Dim myIE
  Dim i As Integer

非常感谢老师的帮忙，代码完全可行！ 不过是否可以帮调整一下代码：如果B列图片网址为空（或无效），同时让C列的文件名值改为空值（删除该文件名）。

sinoshon

我重新修正了一下样列，以方便老师帮助调整VBA，再次表示感谢！！！

Laughing4090

下载下来怎么是xls 没有宏代码

sheis

phsu 发表于 2015-4-6 12:35
Sub DownLoadPics()
  Dim myIE
  Dim i As Integer

超赞！

joelzhang

phsu 发表于 2015-4-6 12:35
Sub DownLoadPics()
  Dim myIE
  Dim i As Integer

为啥到了With Worksheets("Sheet2")报错下标越界呢

phsu

joelzhang 发表于 2021-5-24 07:51
为啥到了With Worksheets("Sheet2")报错下标越界呢

請確認是否有sheet2這個工作表。

joelzhang

phsu 发表于 2021-5-28 06:50
請確認是否有sheet2這個工作表。

问题已经解决了，谢谢，确实是sheet2有问题

TIANSEN

Sub InsertImageFromURL()  
  
    ' 定义变量  
    Dim targetCell As Range  
    Dim imgPath As String  
    Dim img As Picture  
    Dim imgURL As String  
    Dim xmlHttp As Object  
    Dim adodbStream As Object  
  
    ' 图片的URL  
    imgURL = "http://luotuosfoss.oss-cn-shenzhen.aliyuncs.com/sfpublicfiles/client980/PRODUCT/DEV_IMG/980--2438732A2991708398157_38662438732%E5%8D%83%E7%A6%A7%E7%BA%A2.jpg"  
      
    ' 设置目标单元格为G2  
    Set targetCell = ThisWorkbook.Sheets("Sheet1").Range("G2") ' 假设你的工作表名为"Sheet1"  
      
    ' 初始化XMLHTTP和ADODB.Stream对象以下载图片  
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")  
    Set adodbStream = CreateObject("ADODB.Stream")  
      
    ' 发送HTTP GET请求到图片URL  
    xmlHttp.Open "GET", imgURL, False  
    xmlHttp.Send  
      
    ' 如果请求成功，保存图片到临时位置（这里我们直接插入到Excel，不保存到文件）  
    If xmlHttp.Status = 200 Then  
        ' 清除Stream中的任何现有数据  
        adodbStream.Open  
        adodbStream.Type = 1 ' 二进制数据  
         
        ' 将HTTP响应的二进制数据写入Stream  
        adodbStream.write(xmlHttp.responseBody)  
         
        ' 将Stream中的数据保存到Excel工作表中（不保存到文件）  
        ' 注意：Excel的Pictures.Insert方法不直接接受来自Stream的数据，所以我们需要先保存到文件，但这里为了简化，我们直接插入内存中的图片  
        ' 创建一个Picture对象并插入到目标单元格  
        Set img = targetCell.Parent.Pictures.Insert(imgURL) ' 注意：这里实际上不能直接使用URL，但因为我们已经有数据在内存中，我们可以使用其他方法（如Clipboard）  
         
        ' 由于Excel的Pictures.Insert方法不支持直接从内存数据插入，以下是一个简化的插入方法（实际上并未使用内存数据）  
        ' 这里我们只是设置了图片的位置和大小，假设图片已经通过其他方式（如剪贴板）插入  
        With img  
            .ShapeRange.LockAspectRatio = msoFalse  
            .Width = 100 ' 设置图片宽度（可以根据需要调整）  
            .Height = 100 ' 设置图片高度（可以根据需要调整）  
            .Placement = 1 ' 设置为移动但不随单元格大小变化  
            .PrintObject = True  
            .Top = targetCell.Top  
            .Left = targetCell.Left  
            ' 注意：以上代码假设图片已经存在，并且只是调整其位置和大小  
        End With  
         
        ' 清理  
        adodbStream.Close  
        Set adodbStream = Nothing  
    Else  
        MsgBox "Error downloading image: " & xmlHttp.StatusText  
    End If  
      
    ' 清理  
    Set xmlHttp = Nothing  
      
End Sub