Sub BatchImportImages()
Dim fd As FileDialog
Dim imgFolder As String
Dim imgList As Object
Dim ws As Worksheet
Dim startCell As Range
Dim imgWidth As Double, imgHeight As Double
Dim colsPerRow As Integer, rowSpacing As Integer, colSpacing As Integer
Dim boldSpacing As Boolean, fontSize As Integer
' 创建新工作表
Set ws = ThisWorkbook.Sheets.Add
ws.Name = "图片目录"
' 用户参数设置（示例值，可改为从输入框获取）
colsPerRow = 3 ' 每行图片数
rowSpacing = 2 ' 行间隔（行数）
colSpacing = 2 ' 列间隔（列数）
imgWidth = 150 ' 图片宽度
imgHeight = 100 ' 图片高度
boldSpacing = True ' 间隔行加粗
fontSize = 11 ' 字号
' 选择图片文件夹
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show <> -1 Then Exit Sub
imgFolder = fd.SelectedItems(1) & "\"
' 获取图片列表
Set imgList = CreateObject("Scripting.Dictionary")
GetFileList imgFolder, "*.jpg;*.png;*.bmp", imgList
If imgList.Count = 0 Then
MsgBox "未找到图片文件！"
Exit Sub
End If
' 初始化起始位置
Set startCell = ws.Range("A1")
Dim currentRow As Long: currentRow = startCell.Row
Dim currentCol As Long: currentCol = startCell.Column
' 循环插入图片
Dim i As Long, imgPath As Variant
For Each imgPath In imgList.Keys
' 插入图片
With ws.Pictures.Insert(imgPath)
.Top = ws.Cells(currentRow, currentCol).Top
.Left = ws.Cells(currentRow, currentCol).Left
.Width = imgWidth
.Height = imgHeight
.Placement = xlMoveAndSize
End With
' 设置文字描述
ws.Cells(currentRow + 1, currentCol).Value = GetFileName(imgPath)
With ws.Cells(currentRow + 1, currentCol)
.WrapText = True
.VerticalAlignment = xlTop
.HorizontalAlignment = xlJustify
.Font.Size = fontSize
End With
' 更新列位置
currentCol = currentCol + colSpacing + 1
' 换行判断
If (i + 1) Mod colsPerRow = 0 Then
currentRow = currentRow + rowSpacing + 2 ' 图片行+文字行
currentCol = startCell.Column
' 设置间隔行格式
If boldSpacing Then
ws.Rows(currentRow - rowSpacing & ":" & currentRow - 1).Font.Bold = True
End If
End If
i = i + 1
Next imgPath
' 自动调整列宽
ws.Columns.AutoFit
MsgBox "已成功导入 " & imgList.Count & " 张图片！"
End Sub
' 获取文件名列表
Sub GetFileList(folderPath As String, fileFilter As String, ByRef dict As Object)
Dim fileName As String
fileName = Dir(folderPath & fileFilter)
Do While fileName <> ""
dict.Add folderPath & fileName, fileName
fileName = Dir
Loop
End Sub
' 提取纯文件名
Function GetFileName(fullPath As String) As String
GetFileName = Mid(fullPath, InStrRev(fullPath, "\") + 1)
End Function
发表于 2025-3-31 11:09
|
发表于 2025-3-31 14:32
