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

I want to get all the images of a folder, and start inserting them one by one to slowly incrementing cells in Excel. For example, picture 1 should be inserted in cell E1, then picture 2 in cell E2, etc.

我想获取文件夹的所有图像,并开始逐个插入它们以缓慢增加Excel中的单元格。例如,图片1应插入单元格E1,然后图片2插入单元格E2等。

My current code can only get 1 picture from this directory and insert it in a hardcoded cell:

我当前的代码只能从此目录中获取1张图片并将其插入硬编码单元格中:

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

1 个解决方案

#1

Try...

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

To set the LockAspectRatio property to False, and set the width of the picture to the width of the cell...

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

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

Hope this helps!

希望这可以帮助!

#1