在EXCEL中根据单元格的值(对应图片的名称)在指定位置(单元格)动态加入图片需求非常广泛,此举最大的好处是避免了大图片压缩进小单元格会自动压缩图片,导致图片放大后非常的不清晰;如果人工插入图片,有会有对不齐不美观的问题!自动显示图片,就要求必须在指定的文件夹中保存该图片——就保证了图片的质量;显示在单元格中的图片可以理解为小的缩略图,图片的尺寸是根据单元格大小自动计算的!下面就是封装好的函数:
'自动添加图片函数
Public Function AutoInsertPicture(ByVal Target As Range, ByVal PicRowOffset As Integer, ByVal PicColumnOffset As Integer, Optional ByVal PicDir As String = "图片库", Optional ByVal LeftMargin As Integer = 1, Optional ByVal TopMargin As Integer = 1)
'如果单元格为空则退出
If IsEmpty(ActiveCell.Offset(-1, 0)) Then Exit Function
'设置变量
Dim Path As String
Dim Name As String
'图片文件夹所在路径
Path = ThisWorkbook.Path & "\" & PicDir & "\"
Name = ActiveCell.Offset(-1, 0).Value
'定义图片的位置和宽高
mLeft = ActiveCell.Offset(PicRowOffset, PicColumnOffset).MergeArea.Left + LeftMargin
mTop = ActiveCell.Offset(PicRowOffset, PicColumnOffset).MergeArea.Top + TopMargin
mWidth = ActiveCell.Offset(PicRowOffset, PicColumnOffset).MergeArea.Width - LeftMargin * 2
mHeight = ActiveCell.Offset(PicRowOffset, PicColumnOffset).MergeArea.Height - TopMargin * 2
'拼接可能的图片名称
Pic1 = Path + Name + ".png"
Pic2 = Path + Name + ".jpg"
Pic3 = Path + Name + ".gif"
Pic4 = Path + Name + ".bmp"
'删除原来加入的图片
For Each shp In ActiveSheet.Shapes
If shp.Top >= mTop And shp.Left >= mLeft And shp.Top <= mTop + mHeight + 1 And shp.Left <= mLeft + mWidth + 1 Then
shp.Delete
End If
Next
'根据类别添加图片
If IsFileExists(Pic1) Then
ActiveSheet.Shapes.AddPicture Pic1, True, True, mLeft, mTop, mWidth, mHeight
ElseIf IsFileExists(Pic2) Then
ActiveSheet.Shapes.AddPicture Pic2, True, True, mLeft, mTop, mWidth, mHeight
ElseIf IsFileExists(Pic3) Then
ActiveSheet.Shapes.AddPicture Pic3, True, True, mLeft, mTop, mWidth, mHeight
ElseIf IsFileExists(Pic4) Then
ActiveSheet.Shapes.AddPicture Pic4, True, True, mLeft, mTop, mWidth, mHeight
Else
MsgBox PicDir & "文件中不存在该图片,请添加!" & Chr(10) & "图片格式可以:PNG/JPG/GIF/BMP" & Chr(10) & "添加图片后再双击一下单元即可添加图片", vbOKOnly + vbExclamation, "注意"
End If
End Function
有了上面的封装函数,就可以在各个页面中使用了!具体的方法非常简单,只需要用IF语句判断出范围,然后只需要调用一条语句即可:
Private Sub Worksheet_Change(ByVal Target As Range)
'错误时跳过
On Error Resume Next
'自动添加关键岗位的微信头像图片
If Target.Row = 12 And Target.Column >= 3 And Target.Column <= 12 Then Call AutoInsertPicture(Target, -2, 0)
'自动添加本店自有DCC组织机构图片
If Target.Row = 50 And Target.Column = 12 Then Call AutoInsertPicture(Target, 0, 0)
End Sub
附录:判断文件是否存在函数
'判断文件是否存在
Public Function IsFileExists(ByVal strFileName As String) As Boolean
If Dir(strFileName, 16) <> Empty Then
IsFileExists = True
Else
IsFileExists = False
End If
End Function