使用VBA批量导入图片至Excel并保持图片比例

你的代码目前是直接将图片强制拉伸至单元格宽高，破坏了图片原有比例导致变形。要实现保持图片比例并适配单元格，需添加图片比例计算、锁定纵横比、适配尺寸调整的逻辑，修改后的完整代码如下：

Sub InsertPictures()
    Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    Dim picWidth As Double, picHeight As Double
    Dim ratio As Double
    Dim newWidth As Double, newHeight As Double
    
    On Error Resume Next
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
    xColIndex = Application.ActiveCell.Column
    
    If IsArray(PicList) Then
        xRowIndex = Application.ActiveCell.Row
        For lLoop = LBound(PicList) To UBound(PicList)
            Set Rng = Cells(xRowIndex, xColIndex)
            
            ' 以原始尺寸插入图片，避免初始拉伸变形
            Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, 0, 0, -1, -1)
            
            ' 获取图片原始宽高并计算比例
            picWidth = sShape.Width
            picHeight = sShape.Height
            ratio = picWidth / picHeight
            
            ' 根据单元格尺寸计算适配后的图片尺寸（保持比例）
            If Rng.Width / Rng.Height > ratio Then
                ' 单元格偏宽，以单元格高度为基准计算宽度
                newHeight = Rng.Height
                newWidth = newHeight * ratio
            Else
                ' 单元格偏高，以单元格宽度为基准计算高度
                newWidth = Rng.Width
                newHeight = newWidth / ratio
            End If
            
            ' 锁定图片纵横比，设置适配尺寸并居中对齐单元格
            sShape.LockAspectRatio = msoTrue
            sShape.Width = newWidth
            sShape.Height = newHeight
            sShape.Top = Rng.Top + (Rng.Height - newHeight) / 2
            sShape.Left = Rng.Left + (Rng.Width - newWidth) / 2
            
            xRowIndex = xRowIndex + 2
        Next
    End If
End Sub

关键修改说明： #

• 插入图片时使用0, 0, -1, -1参数，让图片以原始尺寸加载，避免初始强制拉伸
• 计算图片原始宽高比，对比单元格宽高比，确定缩放基准（以单元格宽度或高度优先）
• 开启LockAspectRatio = msoTrue锁定比例，防止后续操作导致变形
• 添加图片在单元格内水平+垂直居中的逻辑，优化视觉效果

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