Vba 在保持纵横比的同时将多个图像导入excel

我正在尝试将多个图像从一个目录导入excel。多亏了谷歌，我的宏使图像符合细胞的大小。我想做的是将每个图像的高度设置为100px，同时保持纵横比，并将其插入单元格中。可能吗

这是我找到的宏：

Sub InsertPictures()
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
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, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

任何帮助都将不胜感激

---

另外，我发现kutools for excel可以插入图像，但会强制我定义特定的高度和宽度值。我是否错过了在kutools中维护纵横比的选项？

虽然我不喜欢你在Google上找到的代码，但我修改了它以满足你的要求：

Sub InsertPictures()
    Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    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)
            With ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1)
                .LockAspectRatio = msoTrue
                .Height = 100 * 3 / 4
                Rng.RowHeight = .Height
                Rng.ColumnWidth = .Width / Rng.Width * Rng.ColumnWidth
                Rng.ColumnWidth = .Width / Rng.Width * Rng.ColumnWidth
                Rng.ColumnWidth = .Width / Rng.Width * Rng.ColumnWidth
            End With
            xRowIndex = xRowIndex + 1
        Next
    End If
End Sub

请注意，这将导致在每英寸72点的监视器上仅显示100像素高的图像。对于更高密度的显示器可以这样做，但需要API调用

还请注意，重复三次的行不是打字错误。关于设置Excel列宽，有一种特殊的做法需要这种特殊的做法

更新

您请求的更新也将使图像居中。以下版本正好可以做到这一点：

Sub InsertPictures()
    Dim PicList() As Variant
    Dim PicFormat As String
    Dim Rng As Range
    Dim sShape As Shape
    Dim MaxWidth#
    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)
            With ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1)
                .LockAspectRatio = True
                .Height = 100 * 3 / 4
                Rng.RowHeight = .Height
                If MaxWidth < .Width Then
                    MaxWidth = .Width
                End If
            End With
            xRowIndex = xRowIndex + 1
        Next
        Rng.ColumnWidth = MaxWidth / Rng.Width * Rng.ColumnWidth
        Rng.ColumnWidth = MaxWidth / Rng.Width * Rng.ColumnWidth
        Rng.ColumnWidth = MaxWidth / Rng.Width * Rng.ColumnWidth
        For Each sShape In ActiveSheet.Shapes
            sShape.Left = MaxWidth / 2 - sShape.Width / 2
        Next
    End If
End Sub

子插入图片（）
Dim PicList（）作为变量
字符串格式
变暗Rng As范围
暗淡的形状
Dim最大宽度#
出错时继续下一步
PicList=Application.GetOpenFilename（PicFormat，MultiSelect:=True）
xColIndex=Application.ActiveCell.Column
如果是IsArray（PicList），那么
xRowIndex=Application.ActiveCell.Row
对于lLoop=LBound（PicList）到UBound（PicList）
设置Rng=单元格（xRowIndex，xColIndex）
使用ActiveSheet.Shapes.AddPicture（图片列表（lLoop）、msoFalse、msoCTrue、Rng.Left、Rng.Top、-1、-1）
.LockAspectRatio=真
.高度=100*3/4
Rng.RowHeight=.Height
如果MaxWidth<.Width，则
MaxWidth=.Width
如果结束
以
xRowIndex=xRowIndex+1
下一个
Rng.ColumnWidth=MaxWidth/Rng.Width*Rng.ColumnWidth
Rng.ColumnWidth=MaxWidth/Rng.Width*Rng.ColumnWidth
Rng.ColumnWidth=MaxWidth/Rng.Width*Rng.ColumnWidth
对于ActiveSheet.Shapes中的每个sShape
形状左侧=最大宽度/2-形状宽度/2
下一个
如果结束
端接头

非常感谢您的努力。有一个问题：是否可以将图像水平居中？是的，正是我想要的。非常感谢！：）