ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 6751|回复: 9

[求助] 从图片链接中,批量下载图片并更名

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-4-6 11:38 | 显示全部楼层 |阅读模式
B列为图片的超级链接,将B列的图片下载到此工作薄所在的文件夹下,并用C列的文件名称保存。请见样列!

求高高手帮写一个串VBA,谢谢!

从图片网址批量下载图片.rar

9.98 KB, 下载次数: 384

TA的精华主题

TA的得分主题

发表于 2015-4-6 12:35 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
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

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-4-7 09:20 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
phsu 发表于 2015-4-6 12:35
Sub DownLoadPics()
  Dim myIE
  Dim i As Integer

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2015-4-7 09:21 | 显示全部楼层
我重新修正了一下样列,以方便老师帮助调整VBA,再次表示感谢!!!

从图片网址批量下载图片-V2.rar

9.77 KB, 下载次数: 252

TA的精华主题

TA的得分主题

发表于 2018-3-6 00:08 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
下载下来怎么是xls 没有宏代码

TA的精华主题

TA的得分主题

发表于 2021-3-15 11:10 | 显示全部楼层
phsu 发表于 2015-4-6 12:35
Sub DownLoadPics()
  Dim myIE
  Dim i As Integer

超赞!

TA的精华主题

TA的得分主题

发表于 2021-5-24 07:51 | 显示全部楼层
phsu 发表于 2015-4-6 12:35
Sub DownLoadPics()
  Dim myIE
  Dim i As Integer

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

TA的精华主题

TA的得分主题

发表于 2021-5-28 06:50 | 显示全部楼层
joelzhang 发表于 2021-5-24 07:51
为啥到了With Worksheets("Sheet2")报错下标越界呢

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

TA的精华主题

TA的得分主题

发表于 2021-5-28 08:10 | 显示全部楼层
phsu 发表于 2021-5-28 06:50
請確認是否有sheet2這個工作表。

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

TA的精华主题

TA的得分主题

发表于 2024-5-11 13:26 | 显示全部楼层
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
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-6-16 15:52 , Processed in 0.036313 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表