EXCEL VBA 封装根据单元格值指定位置插入图片函数

在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
最后编辑于
©著作权归作者所有,转载或内容合作请联系作者
平台声明:文章内容(如有图片或视频亦包括在内)由作者上传并发布,文章内容仅代表作者本人观点,简书系信息发布平台,仅提供信息存储服务。

推荐阅读更多精彩内容