如何把URL转换成图片显示

凌空子

vbexcelhome 发表于 2019-12-27 22:40
临时改造了一个下载工具，把你的数据整理一下，然后复制、粘贴，点下载就行了

你好，谢谢。 我刚下载看了下，但是这是下载到了本地，我想直接在表格里自动转化呢？ 我经常需要下载表格，然后url变成图片然后筛选数据，不需要的删掉

凌空子

EXCELLMY 发表于 2019-12-27 10:29
明天联系我吧，明天双休

大佬，起来没呢？

EXCELLMY

凌空子 发表于 2019-12-28 08:49
大佬，起来没呢？

晚上给亲结果

EXCELLMY

凌空子 发表于 2019-12-27 13:32
好的  你微信多少，我加你，这样方便点

http://club.excelhome.net/thread-1488580-2-1.html

Q155133209

凌空子 发表于 2019-12-28 08:49
大佬，起来没呢？

先把你的数据源整理好先吧，一个单元格 2个链接。。

凌空子

Q155133209 发表于 2019-12-28 13:30
先把你的数据源整理好先吧，一个单元格 2个链接。。

你好，我把url那列全部改成了只有一个图片链接，您有空了帮忙看下，谢谢！

aman1516

凌空子 发表于 2019-12-29 08:28
你好，我把url那列全部改成了只有一个图片链接，您有空了帮忙看下，谢谢！

试试：

1. Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
   
2.         
   
3. Sub DownLoadPicture()
   
4. Dim r, rr, url, Pn, Rng
   
5. On Error Resume Next
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. Call Delshp
   
9. rr = [B65536].End(xlUp).Row
   
10. For r = 2 To rr
    
11.     url = Range("B" & r).Value
    
12.     If url <> "" Then
    
13.        On Error Resume Next
    
14.        Pn = Split(url, "/")(UBound(Split(url, "/")))
    
15.        URLDownloadToFile 0, url, ThisWorkbook.Path & "" & Pn, 0, 0
    
16.        Set Rng = Range("C" & r)  '设定插入目标图片的位置
    
17.        With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "" & Pn)  '插入链接地址中的图片
    
18.             If .Height / .Width > Rng.Height / Rng.Width Then  '判断图片纵横比与单元格纵横比的比值以确定针对单元格缩放的比例
    
19.                 .Top = Rng.Top
    
20.                 .Left = Rng.Left + (Rng.Width - .Width * Rng.Height / .Height) / 2
    
21.                 .Width = .Width * Rng.Height / .Height
    
22.                 .Height = Rng.Height
    
23.             Else
    
24.                 .Left = Rng.Left
    
25.                 .Top = Rng.Top + (Rng.Height - .Height * Rng.Width / .Width) / 2
    
26.                 .Height = .Height * Rng.Width / .Width
    
27.                 .Width = Rng.Width
    
28.             End If
    
29.         End With
    
30.         Kill ThisWorkbook.Path & "" & Pn
    
31.     End If
    
32. Next
    
33. Application.DisplayAlerts = True
    
34. Application.ScreenUpdating = True
    
35. MsgBox "OK，图片下载完成!"
    
36. End Sub
    
37. 
    
38. Sub Delshp()
    
39. Application.DisplayAlerts = False
    
40. On Error Resume Next
    
41.     Dim shp As Shape
    
42.     For Each shp In Worksheets("Sheet0").Shapes
    
43.         'If shp.Type = msoPicture Then
    
44.             shp.Delete
    
45.         'End If
    
46.     Next
    
47. Application.DisplayAlerts = True
    
48. End Sub

复制代码

aman1516

详见附件： Keepa_ASIN_Export.2019_12_14.22_products.rar (35.77 KB, 下载次数: 99)

2019-12-29 13:53 上传

点击文件名下载附件

凌空子

aman1516 发表于 2019-12-29 13:53
详见附件：

谢谢。

我这边打开是有个报错，您看下附件截图。  我微信是 lingkongzi123, 可以加我微信聊下吗？谢谢