将文件夹中的图像插入单元格

Question

我想将一个文件夹的所有图像一张一张地插入到 Excel 中的递增单元格中。

例如，图片1应该插入单元格E1，然后图片2插入单元格E2，等等

我的代码只能将此目录中的一张图片插入硬编码单元格中：

Sub Insert()

Dim myPict As Picture
Dim PictureLoc As String
PictureLoc = "C:\MyFolder\Picture1.png"

With Range("E1")
    Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
    .RowHeight = myPict.Height
    myPict.Top = .Top
    myPict.Left = .Left
    myPict.Placement = xlMoveAndSize
End With
End Sub

Answer 1

试试……

Option Explicit

Sub Insert()

    Dim strFolder As String
    Dim strFileName As String
    Dim objPic As Picture
    Dim rngCell As Range

    strFolder = "C:\Users\Domenic\Pictures\Saved Pictures\" 'change the path accordingly
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    Set rngCell = Range("E1") 'starting cell

    strFileName = Dir(strFolder & "*.png", vbNormal) 'filter for .png files

    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.RowHeight
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop

End Sub

要将LockAspectRatio属性设置为False，并将图片的宽度设置为单元格的宽度...

With objPic
    .ShapeRange.LockAspectRatio = False
    .Left = rngCell.Left
    .Top = rngCell.Top
    .Width = rngCell.Width
    .Height = rngCell.RowHeight
    .Placement = xlMoveAndSize
End With

希望这会有所帮助！