【原】Excel批量插入图片，并设置图片超链接

问题描述：

超链接跳转：

涉及知识点：

• 批量插入图片
  

• 为图片设置超链接
  

代码及详解：

Sub 插入图片() Application.ScreenUpdating = False '关闭屏幕刷新，加快运行速度 Call deletepic '清除表格中已有图片 picpath = ThisWorkbook.Path & "\图片\" '图片存放的路径，这里是把图片放在了代码工作簿路径下的【图片】文件夹中 For i = 2 To ActiveSheet.Cells(Rows.Count, 1).End(3).Row '开始循环插入图片，第一行是标题行，所以从第二行开始循环。 Set Rng = ActiveSheet.Cells(i, 2) '插入图片的单元格赋值给对象变量rng j = picpath & ActiveSheet.Cells(i, 1) & ".jpg" '把图片路径赋值给变量j If IsFileExists(j) Then '利用自定义函数判断判断下图片文件是否存在，存在的时候才插入图片，否则会报错。 Set pic = ActiveSheet.Shapes.AddPicture(j, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height) '插入图片 '使用AddPicture方法，将图片插入单元格，并将图片的大小设置成和单元格一致。填满整个单元格区域。 ActiveSheet.Hyperlinks.Add Anchor:=pic, Address:="http://item.taobao.com/item.htm?id=" & ActiveSheet.Cells(i, 1) '位图片设置网址超链接 pic.Placement = xlMoveAndSize '设置属性大小位置均随单元格变化 End If Next '结束For循环 Application.ScreenUpdating = True '开启屏幕刷新 MsgBox "完成！"End SubFunction IsFileExists(ByVal strFileName As String) As Boolean If Dir(strFileName, 16) <> Empty Then IsFileExists = True Else IsFileExists = False End IfEnd FunctionSub deletepic() For Each shp In ActiveSheet.Shapes '对活动工作表中所有的shape对象进行遍历 If shp.Type = 11 Then '如果shape对象类型是【带有超链接的图片】，则删除。 shp.Delete End If NextEnd Sub

判断文件是否存在很有必要，因为不可能保证所有的ID都能找到对应的图片。

• 判断文件是否存在
  

Function IsFileExists(ByVal strFileName As String) As Boolean If Dir(strFileName, 16) <> Empty Then IsFileExists = True Else IsFileExists = False End If End Function Sub Run() If IsFileExists("D:\vba\abc.txt") = True Then ' 文件存在时的处理 MsgBox "文件存在！" Else ' 文件不存在时的处理 MsgBox "文件不存在！" End If End Sub

• 关于AddPicture和Pictureinsert

Excel2010版本以及以后，Pictureinsert只能插入链接，图片不能随文件一起保存，所以建议用AddPicture方法插入图片。