实现的效果:
实现的代码:
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
如果将下面这句话取消注释,其余的代码不变实现的效果: