Excel宏需求：插入图片至单元格并保持宽高比居中显示

原代码的问题在于直接用单元格宽高强制拉伸图片，即使锁定比例也无法保留原始适配效果。以下是修改后的代码，实现按原宽高比居中插入、不改变单元格大小、自动适配横竖版图片的需求：

Sub InsertPictureCentered()
    Dim strFile As String
    Dim targetRng As Range
    Dim picShape As Shape
    Dim originalPicWidth As Double, originalPicHeight As Double
    Dim scaleRatio As Double
    Dim newPicWidth As Double, newPicHeight As Double
    Dim offsetLeft As Double, offsetTop As Double
    Const cFileFilter As String = "图片文件(*.bmp; *.jpg; *.jpeg; *.png; *.tif), *.bmp; *.jpg; *.jpeg; *.png; *.tif"

    ' 选择本地图片文件
    strFile = Application.GetOpenFilename(filefilter:=cFileFilter, Title:="选择要插入的图片")
    If strFile = "False" Then Exit Sub

    ' 定位目标单元格（支持合并区域）
    Set targetRng = ActiveCell.MergeArea

    ' 临时插入图片获取原始尺寸
    Set picShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=strFile, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=0, Top:=0, Width:=msoTrue, Height:=msoTrue)
    
    originalPicWidth = picShape.Width
    originalPicHeight = picShape.Height
    picShape.Delete ' 删除临时图片

    ' 计算适配单元格的缩放比例
    If (originalPicWidth / originalPicHeight) > (targetRng.Width / targetRng.Height) Then
        ' 横版图片：按单元格宽度缩放
        scaleRatio = targetRng.Width / originalPicWidth
    Else
        ' 竖版图片：按单元格高度缩放
        scaleRatio = targetRng.Height / originalPicHeight
    End If

    ' 计算缩放后的图片尺寸
    newPicWidth = originalPicWidth * scaleRatio
    newPicHeight = originalPicHeight * scaleRatio

    ' 计算居中偏移量
    offsetLeft = targetRng.Left + (targetRng.Width - newPicWidth) / 2
    offsetTop = targetRng.Top + (targetRng.Height - newPicHeight) / 2

    ' 插入最终图片并设置居中位置
    Set picShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=strFile, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=offsetLeft, Top:=offsetTop, Width:=newPicWidth, Height:=newPicHeight)
    
    ' 锁定宽高比，防止后续变形
    picShape.LockAspectRatio = msoTrue

    ' 释放对象
    Set picShape = Nothing
    Set targetRng = Nothing
End Sub

关键修改说明 #

• 修复定位错误：将ActiveCell.Range("A4").MergeArea改为ActiveCell.MergeArea，确保选中哪个单元格就插入到对应位置（含合并区域）
• 新增原始尺寸获取：通过临时插入图片获取真实宽高，避免强制拉伸
• 智能缩放逻辑：对比图片与单元格的宽高比，自动选择按宽度或高度缩放，保证图片完整显示且比例不变
• 居中对齐计算：通过偏移量让图片在单元格内水平、垂直居中，横竖版图片自动留空白
• 修正参数错误：替换原代码未定义的Ts为明确的对话框标题，完善文件过滤器格式

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