Excel VBA实现图片嵌入单元格 随单元格移动缩放保宽高比问题

核心修正逻辑：

• 彻底解决图片外链丢失问题：使用Shapes.AddPicture方法时，将LinkToFile参数设为msoFalse、SaveWithDocument参数设为msoTrue，图片会直接存入工作表文件，发送给他人不会出现丢失提示
• 实现单元格绑定：将图片的Placement属性设为xlMoveAndSize（对应值2），图片会跟随所在单元格同步移动、随单元格行高列宽调整同步缩放
• 保持原始宽高比：先读取图片原始宽高，计算图片与目标单元格的宽、高缩放比例，取较小值作为最终缩放系数，避免图片拉伸变形，额外增加居中逻辑让图片在单元格内排版更整齐

可直接使用的完整代码 #

Sub InsertPicToCell()
    Dim selectPath As Variant
    Dim targetCell As Range
    Dim insertedPic As Shape
    Dim cellWidth As Single, cellHeight As Single
    Dim picOriginWidth As Single, picOriginHeight As Single
    Dim fitScale As Single
    
    ' 弹出图片选择对话框，过滤常见图片格式
    selectPath = Application.GetOpenFilename( _
        FileFilter:="图片文件(*.jpg;*.jpeg;*.png;*.bmp;*.gif),*.jpg;*.jpeg;*.png;*.bmp;*.gif", _
        Title:="选择需要插入的图片")
    If selectPath = False Then Exit Sub
    
    ' 定位触发按钮所在的目标单元格
    Set targetCell = ActiveSheet.Shapes(Application.Caller).TopLeftCell
    cellWidth = targetCell.Width
    cellHeight = targetCell.Height
    
    ' 嵌入图片，先读取原始尺寸加载
    Set insertedPic = ActiveSheet.Shapes.AddPicture( _
        Filename:=selectPath, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=targetCell.Left, _
        Top:=targetCell.Top, _
        Width:=-1, _
        Height:=-1)
    
    ' 计算适配比例，锁定宽高比缩放
    picOriginWidth = insertedPic.Width
    picOriginHeight = insertedPic.Height
    fitScale = WorksheetFunction.Min(cellWidth / picOriginWidth, cellHeight / picOriginHeight)
    insertedPic.LockAspectRatio = msoTrue
    insertedPic.Width = picOriginWidth * fitScale
    insertedPic.Height = picOriginHeight * fitScale
    
    ' 图片在单元格内居中
    insertedPic.Left = targetCell.Left + (cellWidth - insertedPic.Width) / 2
    insertedPic.Top = targetCell.Top + (cellHeight - insertedPic.Height) / 2
    
    ' 设置绑定行为、打印可见
    insertedPic.Placement = xlMoveAndSize
    insertedPic.PrintObject = True
End Sub

使用说明 #

• 将上述宏绑定到工作表内的按钮控件，点击按钮即可唤起本地文件选框
• 插入的图片完全内嵌在工作簿中，不存在外链依赖
• 后续调整目标单元格的行高、列宽，或是移动单元格位置时，图片会同步变动，始终保持原始比例不会变形

内容的提问来源于stack exchange，提问作者pdiddy