Excel：vba实现批量插入图片

2024-11-07 07:16:49

实现的效果：

实现的代码：

Sub InsertImageNamesAndPictures()
    Dim PicPath As String
    Dim PicName As String
    Dim PicFullPath As String
    Dim RowNum As Integer
    Dim Pic As Object
    Dim Name As String
    
    ' 防止表格里面有脏数据
    Cells.Clear
    ' 遍历工作表中的每个图片并删除,防止表中有别的图片，造成叠加
    For Each Pic In ActiveSheet.Pictures
        Pic.Delete
    Next Pic
    
    ' 修改为你的图片文件夹路径
    PicPath = "C:\Users\HUAWEI\Pictures\Screenshots\"
    
    ' 初始化行号
    RowNum = 1
    
    ' 获取文件夹中的第一个文件名
    PicName = Dir(PicPath & "*.*")
    
    ' 遍历所有图片文件
    Do While PicName <> ""
        '去掉文件扩展名(即去掉文件后缀)
        'Name = Left(PicName, InStrRev(PicName, ".") - 1)
        ' 将图片文件名插入到A列
        Cells(RowNum, 1).value = PicName
        
        ' 拼接完整路径
        PicFullPath = PicPath & PicName
        
        ' 插入图片到B列
        Set Pic = ActiveSheet.Pictures.Insert(PicFullPath)
        
        ' 设置图片位置和大小
        With Pic
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Cells(RowNum, 2).Top
            .Left = Cells(RowNum, 2).Left
            .Width = 50  ' 可调整宽度
            .Height = 50 ' 可调整高度
        End With
        
        ' 设置行高
        Rows(RowNum).RowHeight = Pic.Height
        
        ' 移动到下一行
        RowNum = RowNum + 1
        
        ' 获取下一个文件名
        PicName = Dir
    Loop
End Sub