在保持宽高比的同时将多个图像导入到excel中

我试图从一个目录导入多个图像到Excel中。 这个macros，我感谢谷歌，使图像符合细胞的大小。 我想要做的是将每个图像的高度设置为100像素，同时保持纵横比并将其插入到单元格中。 那可能吗？

这个macros我发现：

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 

任何帮助将非常感激。

PS。 我find了插入图像的excel的kutools，但强制我定义特定的高度和宽度值。 我错过了维持kutools长宽比的select吗？

Answer 1

虽然不喜欢您在Google上find的代码，但我已将其修改为符合您的要求：

 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 

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

还要注意，重复三次的行不是一个错字。 有关设置Excel列宽的特性需要这种不寻常的做法。

UPDATE

您请求了一个更新，将图像居中。 以下版本将做到这一点：

 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