Question

我正在尝试将多个图像从目录导入到Excel中。感谢Google，我拥有的宏可以使图像符合单元格的大小。我想要做的是将每个图像的高度设置为100像素，同时保持纵横比并将其插入单元格。这可能吗？

这是我发现的宏：

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。我发现excel的kutools插入图像但强迫我定义一个特定的高度和宽度值。我是否错过了在kutools中保持宽高比的选择？

Answer 1

虽然不喜欢您在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

将多个图像导入excel，同时保持纵横比

1 个答案: