批量导入和查询图片

wangg913

本附件数据是从百度百科摘抄的，图片也是度娘而得到的。
1、批量导入图片
判断A列数据是否已经导入图片，如果没有图片，将图片放置在B列相应位置。
数据可以追加，追加数据时为避免重复导入图片，并且方便后期“查询模块”引用图片，将B列设置为识别符。
如B列相应单元格为空，则加载图片，否则表明已经载入了图片。

1. Option Explicit
   
2. Private Sub CommandButton1_Click()
   
3. Dim I&
   
4. Dim Picfile$, PicRng As Range
   
5. Dim dCuisine, HasPicture
   
6. dCuisine = Range("A3", Range("A3000").End(xlUp))
   
7. HasPicture = Range("B3").Resize(UBound(dCuisine), 1)
   
8. For I = 1 To UBound(dCuisine)
   
9.     '利用B列存放图片的单元格，设置一个识别符。
   
10.     '此识别符用于判断相关项目是否已经导入图片，如果识别符不为空，则判断已经导入了图片。
    
11.     '如果识别符为空，则查询是否存在图片，如存在就加载。
    
12.     If dCuisine(I, 1) <> "" And HasPicture(I, 1) = "" Then
    
13.         '取得图片文件名，常用的 bmp、jpg、png文件类型都可以
    
14.         Picfile = Dir(ThisWorkbook.Path & "\图片" & dCuisine(I, 1) & ".*")
    
15.         '如果查到匹配图片，则进行加载。
    
16.         If Picfile <> "" Then
    
17.             '存放图片的单元格。
    
18.             Set PicRng = Sheet2.Range("B" & I + 2)
    
19.             Picfile = ThisWorkbook.Path & "\图片" & Picfile
    
20.             '加载图片，并调整图片的大小与单元格大小适应。
    
21.             With Sheet2.Shapes.AddPicture(Picfile, msoTrue, msoTrue, _
    
22.                     PicRng.Left + 2, PicRng.Top + 2, PicRng.Width - 4, PicRng.Height - 4)
    
23.                 '图片对象更名，更名为A列项目名称，以便“查询模块”调用。
    
24.                 .Name = dCuisine(I, 1)
    
25.             End With
    
26.             '添加识别符
    
27.             PicRng.Value = dCuisine(I, 1)
    
28.         End If
    
29.     End If
    
30. Next
    
31. End Sub

复制代码

2、查询引用图片
同上，如果识别符为空，直接引用工作表“批量导入”的图片。

1. Option Explicit
   
2. Private Sub CommandButton1_Click()
   
3. Dim A&, PicRng As Range
   
4. Dim dCuisine, HasPicture
   
5. dCuisine = Range("A3", Range("A3000").End(xlUp))
   
6. HasPicture = Range("B3").Resize(UBound(dCuisine), 1)
   
7. For A = 1 To UBound(dCuisine)
   
8.     If dCuisine(A, 1) <> "" And HasPicture(A, 1) = "" Then
   
9.         On Error Resume Next
   
10.         If Sheet2.Shapes(dCuisine(A, 1)) Is Nothing Then
    
11.             GoTo ContinueFor
    
12.         End If
    
13.         Sheet2.Shapes(dCuisine(A, 1)).Copy
    
14.         Set PicRng = Range("B2").Offset(A)
    
15.         PicRng.Activate
    
16.         Sheet1.Paste
    
17.         With Selection
    
18.             .Left = PicRng.Left + 2
    
19.             .Top = PicRng.Top + 2
    
20.             .Height = PicRng.Height - 4
    
21.             .Width = PicRng.Width - 4
    
22.             .Name = dCuisine(A, 1)
    
23.         End With
    
24.         PicRng.Value = dCuisine(A, 1)
    
25.     End If
    
26. ContinueFor:
    
27. Next
    
28. End Sub

复制代码

附件： 20150723-图片的导入与查询.rar (1.75 MB, 下载次数: 825)

2015-7-27 21:22 上传

点击文件名下载附件

coby001

居然没用到 shape.TopLeftCell 属性，差评~

wangg913

coby001 发表于 2015-7-27 21:44
居然没用到 shape.TopLeftCell 属性，差评~

如果用到 TOPLEFTCELL，那么每次都要判断全部图片对象和当前单元格的交集区域。
如果图片超过几千，效率就非常底下了。
因此特意避免使用“那个著名的解决办法”。

coby001

wangg913 发表于 2015-7-27 21:54
如果用到 TOPLEFTCELL，那么每次都要判断全部图片对象和当前单元格的交集区域。
如果图片超过几千，效率 ...

图片超过几千？
居然在excel里放几千图片？
匪夷所思~

coby001

没必要放那么多图片的

放一个 image控件和几个按钮，让他轮流看图片和相关信息即可

wangg913

coby001 发表于 2015-7-27 22:08
没必要放那么多图片的

放一个 image控件和几个按钮，让他轮流看图片和相关信息即可

是的，这样最好了。
不过，有时基础数据不是自己说了算。

02761752696

谢谢     分享