求助根据货品批量引用网络图片

erwen

根据货品批量引用网络图片，附件里是公式显示图片，需要点击，浏览器打开后要下载插入才可以。而且主要网址结尾不是jpg等图片后缀。试过很多方法都不行，求大神指导 链接格式-货号图片.rar (101.39 KB, 下载次数: 15)

2019-10-10 10:24 上传

点击文件名下载附件

我在天外

看看吧，自己看需求改把

erwen

我在天外 发表于 2019-10-10 11:55
看看吧，自己看需求改把

大神不行，宏报错，也看不到宏

erwen

朱荣兴 发表于 2019-10-10 11:46
你是需要把图片下载到单元格中？？

是的，在表格中直接显示图片

petergaod

我这个你应该可以用，自己拿去改改

我在天外

erwen 发表于 2019-10-10 12:31
大神不行，宏报错，也看不到宏

1. Sub getIMG()
   
2. Dim imgURL$
   
3. Dim XML As Object
   
4. Dim cellNO As Integer
   
5. Dim wj As String
   
6. Dim rng As Range
   
7. Dim picData() As Byte
   
8. 
   
9. Dim picW As Single, picH As Single
   
10. Dim cellW As Single, cellH As Single
    
11. Dim rtoW As Single, rtoH As Single
    
12. 
    
13. Set XML = CreateObject("msxml2.xmlhttp")
    
14.    
    
15. Dim p As Integer
    
16. For p = 2 To Application.CountA(Sheet6.Range("A:A"))
    
17.     imgURL = Sheet6.Cells(p, "E")
    
18.     Debug.Print imgURL, Application.CountA(Sheet5.Range("A:A"))
    
19.     Rem 下载图片，保存于工作薄同路径下，命名为temp1.jpg
    
20.      With XML
    
21.         .Open "GET", imgURL, False
    
22.         .send
    
23.         picData = .responsebody
    
24.         fp = ThisWorkbook.Path & "\temp1.jpg"
    
25.    
    
26.         Open fp For Binary Access Write As #1
    
27.             Put #1, 1, picData
    
28.         Close #1
    
29. 
    
30. 
    
31. 
    
32.          Sheet6.Cells(p, 8).Select
    
33.          Sheet6.Pictures.Insert(fp).Select
    
34. 
    
35. Rem 自适应大小
    
36.         cellW = ActiveCell.Width
    
37.         cellH = ActiveCell.Height
    
38.         picW = Selection.ShapeRange.Width
    
39.         picH = Selection.ShapeRange.Height
    
40.         rtoW = cellW / picW * 0.99
    
41.         rtoH = cellH / picH * 0.99
    
42.         If rtoW < rtoH Then
    
43.             Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
    
44.         Else
    
45.             Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
    
46.         End If
    
47.         picW = Selection.ShapeRange.Width
    
48.         picH = Selection.ShapeRange.Height
    
49.         Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
    
50.         Selection.ShapeRange.IncrementTop (cellH - picH) / 2
    
51.                
    
52. 
    
53.     End With
    
54.     Kill fp
    
55. Next
    
56. End Sub
    
57. 
    
58. Sub DeletePic()
    
59.     Dim p As Shape
    
60.     For Each p In Sheet6.Shapes
    
61.         If p.Type = 11 Then
    
62.             p.Delete
    
63.         End If
    
64.     Next
    
65. End Sub
    
66. 
    
67. 
    

复制代码

不好意思，打包错了

zpy2

erwen 发表于 2019-10-10 12:59
是的，在表格中直接显示图片

直接在线显示图片也不错的。