本文介绍的 VBA 脚本主要实现以下功能：
为什么选择Excel结合VBA与FFmpeg处理图片？
1.多功能集成，一站式解决方案
集成图片的批量选择、调整尺寸、压缩质量以及合并功能，满足在不同场景下的多样化需求，无需切换多个软件工具。
2.自动化操作，省时省力
通过双击Excel中的指定单元格，即可自动执行复杂的图片处理任务，减少手动操作，提升工作效率。
3.灵活定制，适应不同需求
根据具体需求设置目标宽度、高度、压缩质量，并选择合并方式（水平或垂直），灵活应对各种图片处理场景。
4.高质量输出，保证专业水准
借助FFmpeg的强大处理能力，确保处理后的图片质量，无论是用于商业展示还是个人项目，都能达到专业水准。
功能亮点详解
1.批量选择与导入图片路径
通过双击Excel中的A1单元格，弹出文件选择对话框，轻松选择多张图片。选定的图片路径将自动填入A列，便于后续管理与处理。
2.智能获取图片信息
系统自动读取每张图片的格式、分辨率及文件大小，信息一目了然，可以更好地了解和管理图片资源。
3.批量调整图片尺寸与压缩质量
在E 、F列填写目标宽度和高度，G列填写压缩质量（默认值为2）。双击I1单元格，VBA脚本将自动调整所有选定图片的尺寸与质量，处理后的图片将保存在新建的文件夹中。
4.灵活合并图片
- 水平合并：
双击K1单元格，即可将选定的多张图片水平拼接成一张长图，适用于制作横幅或展示图集。
- 垂直合并：
双击J1单元格，即可将选定的多张图片垂直堆叠成一张高图，适用于制作竖版海报或图册。
5.自动化管理，提升效率
处理完成后，所有优化后的图片将自动保存在指定文件夹中，整洁有序，便于后续使用与管理。同时，生成详细的日志文件，方便追踪与排查问题。
下面，我们将逐一解析每个部分的具体实现和功能。
1. 双击单元格事件处理，Worksheet_BeforeDoubleClick 事件
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If Target.Address = "$A$1" Then
Call GetSelectedImagePaths
Cancel = True
End If
If Target.Address = "$I$1" Then
Call RunFFCommand
Cancel = True
End If
If Left(Target.Address, 2) = "$I" Or Left(Target.Address, 2) = "$A" Then
If Target.Address <> "$I$1" And Target.Address <> "$A$1" Then
If Target.Value <> "" Then
Cancel = True
ThisWorkbook.FollowHyperlink Address:=Target.Value
End If
End If
End If
If Target.Address = "$J$1" Then
Call VMergeImagesRecursively
Cancel = True
End If
If Target.Address = "$K$1" Then
Call HorizontalImageMerger
Cancel = True
End If
End Sub功能说明：
* 触发条件：当用户在工作表中双击某个单元格时，该事件被触发。
* 操作逻辑：
* 双击 $A$1 单元格：调用 GetSelectedImagePaths 子程序，用于选择图片文件路径。
* 双击 $I$1 单元格：调用 RunFFCommand 子程序，执行 FFmpeg 命令。
* 双击 $I 或 $A 列的其他单元格：如果单元格有值，跳转到该值对应的超链接。
* 双击 $J$1 单元格：调用 VMergeImagesRecursively 子程序，执行垂直合并图像操作。
* 双击 $K$1 单元格：调用 HorizontalImageMerger 子程序，执行水平合并图像操作。通过这种方式，用户可以通过简单的双击操作，快速执行不同的图像处理任务，提高工作效率。
2.FFmpeg进程管理，KillFFmpegIfRunning 子程序
Sub KillFFmpegIfRunning()
On Error Resume Next
Dim objWMI As Object
Dim objProcess As Object
Dim colProcess As Object
' 获取WMI服务
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
If objWMI Is Nothing Then
Exit Sub
End If
' 查询进程
Set colProcess = objWMI.ExecQuery("Select * from Win32_Process Where Name = 'ffmpeg.exe'")
If colProcess.Count = 0 Then
Exit Sub
End If
' 遍历并终止所有FFmpeg进程
For Each objProcess In colProcess
objProcess.Terminate
Next
End Sub功能说明：
* 目的：在需要时终止所有正在运行的 FFmpeg 进程，释放系统资源。
* 实现方法：
* 利用 WMI（Windows Management Instrumentation）查询系统中所有名为 ffmpeg.exe 的进程。
* 遍历查询结果，逐个终止这些进程。这种方法确保在执行图像处理任务前，系统中不会有残留的 FFmpeg 进程占用资源，避免潜在的冲突和资源浪费。
3. 工作表格式化，FormatContext 子程序
Sub FormatContext()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets(1).Range("A1:K" & [a65536].End(3).Row)
.Font.Name = "宋体"
.Font.Size = 12
.Font.Underline = xlUnderlineStyleNone
.Font.ColorIndex = xlAutomatic
.Borders.LineStyle = xlContinuous
.Borders.ColorIndex = 0
.Borders.TintAndShade = 0
.Borders.Weight = xlThin
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
Sheets(1).Rows("2:10000").RowHeight = 13.25
Sheets(1).Range("B2").Select
Sheets(1).Cells.EntireColumn.AutoFit
Columns("I:I").ColumnWidth = Columns("A:A").ColumnWidth + 20
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
功能说明：
* 目的：统一格式化工作表，提高可读性和美观度。
* 操作内容：
* 字体设置：使用“宋体”字体，字号为12，取消下划线，自动颜色。
* 边框设置：为范围内的单元格添加连续线条边框，线条颜色为默认。
* 对齐方式：水平左对齐，垂直居中。
* 文本格式：取消自动换行，取消单元格合并。
* 行高与列宽调整：
* 设置第2行到第10000行的行高为13.25。
* 自动调整所有列的宽度以适应内容。
* 将列 I 的宽度设置为列 A 宽度加20，以容纳更长的内容。通过该子程序，可以确保生成的工作表具有统一且专业的外观，便于用户查看和操作。
4. 选择并处理图片路径，GetSelectedImagePaths 子程序
Sub GetSelectedImagePaths()
Dim fd As FileDialog
Dim i As Long
Dim ws As Worksheet
Dim selectedFilePath As Variant
' 设置当前工作表
Set ws = ThisWorkbook.Sheets(1) ' 修改为目标工作表名称或索引
' 创建文件选择对话框
Set fd = Application.FileDialog(msoFileDialogFilePicker)
' 配置对话框属性
With fd
.Title = "选择图片文件"
.Filters.Clear
.Filters.Add "图片文件", "*.jpg; *.jpeg; *.png; *.gif; *.bmp;*.tif;*.tiff;*.ico"
.AllowMultiSelect = True
' 如果用户选择了文件
If .Show = -1 Then
' 初始化起始单元格行
Rows("2:65536").Clear
i = 2
' 遍历选中的文件路径
For Each selectedFilePath In .SelectedItems
' 写入文件路径到A列
ws.Cells(i, 1).Value = selectedFilePath
i = i + 1
Next selectedFilePath
Else
Exit Sub
End If
End With
Call RunGetImageResolutionAsDictionary
Call FormatContext
End Sub功能说明：
* 目的：通过文件对话框让用户选择多个图片文件，并将选中的文件路径写入工作表的 A 列。
* 实现步骤：
1.创建文件对话框：设置标题为“选择图片文件”，过滤器仅显示常见的图片格式（如 JPG、PNG 等），允许多选。
2.用户选择文件：
* 如果用户选择了文件，清空工作表第2行到最后一行的内容，从第2行开始，将每个选中的文件路径写入 A 列。
* 如果用户取消操作，则退出子程序。
3.后续操作：
* 调用 RunGetImageResolutionAsDictionary 子程序，获取每个图片的分辨率和其他信息。
* 调用 FormatContext 子程序，格式化工作表此子程序简化了用户选择和记录图片路径的过程，为后续的图像处理打下基础。
5. 获取图片分辨率信息，GetImageResolutionAsDictionary 函数
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal fileName As LongPtr, ByRef bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" (ByVal image As LongPtr, ByRef width As Long) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" (ByVal image As LongPtr, ByRef height As Long) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, ByVal outputbuf As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Function GetImageResolutionAsDictionary(ByVal filePath As String) As Object
Dim token As LongPtr
Dim startupInput As GdiplusStartupInput
Dim image As LongPtr
Dim width As Long, height As Long
Dim status As Long
Dim fileExt As String
Dim resultDict As Object ' 用于存储返回值的字典
Dim fso As Object
Dim fileSize As Double
' 创建字典对象
Set resultDict = CreateObject("Scripting.Dictionary")
' 检查文件格式
fileExt = LCase(Right(filePath, Len(filePath) - InStrRev(filePath, ".")))
If fileExt <> "jpg" And fileExt <> "jpeg" And fileExt <> "png" And fileExt <> "gif" And fileExt <> "bmp" And fileExt <> "tif" And fileExt <> "tiff" And fileExt <> "ico" Then
resultDict("Error") = "Unsupported format: " & fileExt
Set GetImageResolutionAsDictionary = resultDict
Exit Function
End If
' 获取文件大小
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filePath) Then
fileSize = fso.GetFile(filePath).Size ' 获取文件大小
Else
resultDict("Error") = "File not found: " & filePath
Set GetImageResolutionAsDictionary = resultDict
Exit Function
End If
' 初始化GDI+
startupInput.GdiplusVersion = 1
status = GdiplusStartup(token, startupInput, 0)
If status <> 0 Then
resultDict("Error") = "Error initializing GDI+"
Set GetImageResolutionAsDictionary = resultDict
Exit Function
End If
' 加载图片
status = GdipCreateBitmapFromFile(StrPtr(filePath), image)
If status <> 0 Then
resultDict("Error") = "Error loading image"
GdiplusShutdown token
Set GetImageResolutionAsDictionary = resultDict
Exit Function
End If
' 获取图片宽高
GdipGetImageWidth image, width
GdipGetImageHeight image, height
' 将结果存储到字典中
resultDict("Format") = fileExt
resultDict("Width") = width
resultDict("Height") = height
resultDict("Size") = fileSize ' 文件大小（字节）
' 释放图片资源
GdipDisposeImage image
' 关闭GDI+
GdiplusShutdown token
' 返回字典
Set GetImageResolutionAsDictionary = resultDict
End Function功能说明：
* 目的：获取指定图片文件的格式、宽度、高度和文件大小。
* 实现方法：
1.格式验证：检查文件扩展名是否为支持的图片格式（如 JPG、PNG 等）。
2.文件存在性检查：确认文件是否存在。
3.GDI+ 初始化：利用 GDI+ API 加载图片文件。
4.获取图像信息：
* 获取图片的宽度和高度。
* 获取文件大小（以字节为单位）。
5.资源释放：释放加载的图片资源，关闭 GDI+。
6.结果返回：将获取的信息存储在字典对象中返回。该函数通过直接调用 GDI+ API，能够高效准确地获取图片的详细信息，为后续的数据处理提供支持。
5.1 RunGetImageResolutionAsDictionary 子程序
Sub RunGetImageResolutionAsDictionary()
Dim resolutionDict As Object
Dim filePath As String
Dim lastRow As Long
Dim rng1 As Range
Dim ws As Worksheet
' 设置目标工作表
Set ws = ThisWorkbook.Sheets(1)
' 确定最后一行
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' 遍历A列中的文件路径，从第2行开始
For Each rng1 In ws.Range("A2:A" & lastRow)
If Len(rng1.Value) > 0 Then ' 如果单元格不为空
filePath = rng1.Value
Set resolutionDict = GetImageResolutionAsDictionary(filePath) ' 调用函数获取分辨率信息
If resolutionDict.Exists("Error") Then
' 如果出错，将错误信息写入相邻列
'rng1.Offset(0, 1).Value = resolutionDict("Error")
rng1.Interior.Color = RGB(255, 0, 0)
rng1.Offset(0, 4).Value = -1
rng1.Offset(0, 5).Value = -1
rng1.Offset(0, 6).Value = 2
rng1.Offset(0, 7).Value = LCase(Right(rng1.Value, Len(rng1.Value) - InStrRev(rng1.Value, ".")))
Else
' 如果成功，写入格式、宽度和高度
'rng1.Offset(0, 1).Value = resolutionDict("Format")
rng1.Offset(0, 1).Value = resolutionDict("Width")
rng1.Offset(0, 2).Value = resolutionDict("Height")
rng1.Offset(0, 3).Value = Format(resolutionDict("Size") / 1048576, "0.00")
rng1.Offset(0, 4).Value = -1
rng1.Offset(0, 5).Value = -1
rng1.Offset(0, 6).Value = 2
rng1.Offset(0, 7).Value = resolutionDict("Format")
End If
End If
Next rng1
End Sub功能说明：
* 目的：遍历工作表 A 列中的图片文件路径，调用 GetImageResolutionAsDictionary 函数获取每个图片的详细信息，并将结果写入相邻的列中。
* 实现步骤：
1.遍历 A 列：从第2行开始，遍历所有非空的单元格。
2.获取图片信息：调用 GetImageResolutionAsDictionary 函数，获取每个图片的格式、宽度、高度和大小。
3.结果处理：
* 出错处理：如果获取信息时发生错误（如不支持的格式或文件不存在），将单元格背景颜色设置为红色，并在相关列中标记错误信息。
* 成功处理：将图片的宽度、高度、大小（以MB为单位）和格式写入相应的列中，同时设置其他相关信息。通过该子程序，用户可以直观地在工作表中查看每个图片的详细信息，便于后续的筛选和处理。
6. 水平合并图像，HorizontalImageMerger 子程序
Sub HorizontalImageMerger()
Dim ffmpegExecutablePath As String
Dim finalMergedImagePath As String
Dim imagePaths As Collection
Dim currentCell As Range
Dim userSelectedRange As Range
Dim temporaryFolderPath As String
Dim tempFileNamePrefix As String
Dim imagesPerBatch As Long
Dim mergedImageFiles As Collection
Dim maximumIterations As Long
Dim iterationCount As Long
Dim logFilePath As String
Dim logFileStream As Object
Dim uniqueMergeCounter As Long
' Set FFmpeg path
ffmpegExecutablePath = ThisWorkbook.Path & "\bin\ffmpeg.exe" ' Modify to the full path of FFmpeg if needed
' Verify FFmpeg exists
If Dir(ffmpegExecutablePath) = "" Then
MsgBox "FFmpeg executable not found: " & ffmpegExecutablePath, vbCritical
Exit Sub
End If
' Set the final output image path with timestamp
finalMergedImagePath = ThisWorkbook.Path & "\Successful\" & Format(Now, "yyyy_mm_dd_hhmmss") & ".jpg"
If Dir(ThisWorkbook.Path & "\Successful\", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\Successful\"
End If
' Set temporary folder path
temporaryFolderPath = ThisWorkbook.Path & "\temp_ffmpeg_merge"
If Dir(temporaryFolderPath, vbDirectory) = "" Then
MkDir temporaryFolderPath
End If
' Set temporary file prefix
tempFileNamePrefix = "temp_merge_"
' Set the number of images to merge per batch
imagesPerBatch = 4 ' Adjust as needed to reduce the number of iterations
' Initialize the collection to store image paths
Set imagePaths = New Collection
' Initialize log file
logFilePath = ThisWorkbook.Path & "\merge_log.txt"
Set logFileStream = CreateObject("Scripting.FileSystemObject").CreateTextFile(logFilePath, True)
' Initialize merge counter
uniqueMergeCounter = 1
' Get the user-selected cell range
On Error Resume Next
Set userSelectedRange = Application.InputBox("Please select the cell range containing image paths (Column I, starting from I2):", "Select Image Paths", Type:=8)
On Error GoTo 0
If userSelectedRange Is Nothing Then
MsgBox "No cells selected. Operation canceled.", vbExclamation
logFileStream.WriteLine "No cells selected. Operation canceled."
logFileStream.Close
Exit Sub
End If
' Collect image paths
For Each currentCell In userSelectedRange
If currentCell.Column = 9 Then ' Column I is the 9th column
If Trim(currentCell.Value) <> "" Then
imagePaths.Add currentCell.Value
End If
End If
Next currentCell
If imagePaths.Count < 1 Then
MsgBox "No image paths found. Please ensure the selected cells contain valid image paths.", vbExclamation
logFileStream.WriteLine "No image paths found."
logFileStream.Close
Exit Sub
End If
' Check if all image files exist
Dim index As Long
For index = 1 To imagePaths.Count
If Dir(imagePaths(index)) = "" Then
MsgBox "Image file not found: " & imagePaths(index), vbCritical
logFileStream.WriteLine "Image file not found: " & imagePaths(index)
logFileStream.Close
Exit Sub
End If
Next index
' Log start time and total image count
logFileStream.WriteLine "Start merging images: " & Now
logFileStream.WriteLine "Total number of images: " & imagePaths.Count
' Start initial merging
Set mergedImageFiles = BatchMergeImages(imagePaths, ffmpegExecutablePath, temporaryFolderPath, tempFileNamePrefix, imagesPerBatch, logFileStream, "hstack", uniqueMergeCounter)
' Set maximum number of iterations to prevent infinite loops
maximumIterations = 10
iterationCount = 0
' Recursively merge until only one file remains or maximum iterations are reached
Do While mergedImageFiles.Count > 1 And iterationCount < maximumIterations
Set mergedImageFiles = BatchMergeImages(mergedImageFiles, ffmpegExecutablePath, temporaryFolderPath, tempFileNamePrefix, imagesPerBatch, logFileStream, "hstack", uniqueMergeCounter)
iterationCount = iterationCount + 1
logFileStream.WriteLine "Iteration: " & iterationCount & ", Remaining files: " & mergedImageFiles.Count
Loop
' Check if successfully merged into one file
If mergedImageFiles.Count = 1 Then
' Convert the final merged PNG to JPG
Dim finalPngFile As String
finalPngFile = mergedImageFiles(1)
' Build FFmpeg command to convert PNG to JPG
Dim conversionCommand As String
conversionCommand = """" & ffmpegExecutablePath & """ -i """ & finalPngFile & """ -q:v 2 """ & finalMergedImagePath & """"
logFileStream.WriteLine "Converting PNG to JPG: " & conversionCommand
' Execute conversion command
If Not RunFFmpegCommand(conversionCommand) Then
MsgBox "Failed to convert final PNG to JPG.", vbCritical
logFileStream.WriteLine "Failed to convert final PNG to JPG: " & conversionCommand
logFileStream.Close
Exit Sub
End If
' Delete the final PNG file
If Dir(finalPngFile) <> "" Then
Kill finalPngFile
logFileStream.WriteLine "Deleted temporary PNG file: " & finalPngFile
End If
logFileStream.WriteLine "Successfully merged images into: " & finalMergedImagePath
Else
MsgBox "Merging process did not complete. There may be an issue with the merging steps or it exceeded the maximum number of iterations.", vbCritical
logFileStream.WriteLine "Merging process did not complete. Final file count: " & mergedImageFiles.Count
logFileStream.Close
Exit Sub
End If
' Delete the temporary folder and its contents
RemoveTemporaryFolder temporaryFolderPath
logFileStream.WriteLine "Deleted temporary folder: " & temporaryFolderPath
' Log end time
logFileStream.WriteLine "Image merging completed: " & Now
logFileStream.Close
' Notify the user
If Dir(finalMergedImagePath) <> "" Then
MsgBox "Images have been successfully merged and saved as: " & finalMergedImagePath, vbInformation
Else
MsgBox "Image merging failed. Please check the FFmpeg commands and ensure all image paths are valid.", vbCritical
End If
End Sub功能说明：
* 目的：使用 FFmpeg 工具将选定的多张图片水平合并为一张图片。
* 实现步骤：
1.FFmpeg 路径设置：指定 FFmpeg 可执行文件的位置，默认位于工作簿所在路径的 bin 文件夹中。
2.输出路径设置：设置合并后图片的保存路径，文件名包含时间戳。
3.临时文件夹创建：用于存放中间合并生成的临时文件。
4.用户选择图片范围：弹出对话框让用户选择包含图片路径的单元格区域（默认列为 I 列）。
5.图片存在性检查：确保所有选定的图片文件都存在。
6.批量合并：调用 BatchMergeImages 函数，将图片分批次合并，直到最终只剩一张合并后的图片。
7.PNG 转 JPG：将最终的 PNG 格式图片转换为 JPG 格式。
8.清理临时文件：删除临时文件夹及其内容。
9.日志记录：记录合并过程中的详细信息，便于后续排查问题。6.1 BatchMergeImages 函数
Function BatchMergeImages(inputFiles As Collection, ffmpegPath As String, tempFolder As String, tempPrefix As String, batchSize As Long, logStream As Object, mergeType As String, ByRef mergeCounter As Long) As Collection
Dim outputFiles As New Collection
Dim i As Long, batchNumber As Long
Dim currentBatch As New Collection
Dim tempOutputPath As String
Dim ffmpegCommand As String
Dim j As Long
batchNumber = 1
For i = 1 To inputFiles.Count
currentBatch.Add inputFiles(i)
If currentBatch.Count = batchSize Or i = inputFiles.Count Then
If currentBatch.Count = 1 Then
' Only one image, no need to merge, directly add to output collection
outputFiles.Add currentBatch(1)
logStream.WriteLine "Batch " & batchNumber & ": Single image, skipping merge: " & currentBatch(1)
Else
' Set temporary output file name as PNG to ensure uniqueness
tempOutputPath = tempFolder & "\" & tempPrefix & mergeCounter & ".png"
' Build FFmpeg command
ffmpegCommand = """" & ffmpegPath & """"
For j = 1 To currentBatch.Count
ffmpegCommand = ffmpegCommand & " -i """ & currentBatch(j) & """"
Next j
ffmpegCommand = ffmpegCommand & " -filter_complex """ & mergeType & "=inputs=" & currentBatch.Count & """ """ & tempOutputPath & """"
' Log the command
logStream.WriteLine "Batch " & batchNumber & ": Executing FFmpeg command: " & ffmpegCommand
' Execute FFmpeg command
If Not RunFFmpegCommand(ffmpegCommand) Then
MsgBox "Failed to execute FFmpeg command:" & vbCrLf & ffmpegCommand, vbCritical
logStream.WriteLine "Failed to execute FFmpeg command: " & ffmpegCommand
Exit Function
Else
logStream.WriteLine "Batch " & batchNumber & ": Successfully merged into " & tempOutputPath
outputFiles.Add tempOutputPath
mergeCounter = mergeCounter + 1
End If
' Increment batch counter
batchNumber = batchNumber + 1
End If
' Reset the current batch
Set currentBatch = New Collection
End If
Next i
Set BatchMergeImages = outputFiles
End Function功能说明：
* 目的：将输入的图片文件集合分批次进行合并，支持水平（hstack）或垂直（vstack）合并。
* 实现方法：
1.批次处理：根据设定的 batchSize（每批次合并的图片数量），将输入文件集合分成若干批次。
2.FFmpeg 命令构建：为每个批次构建相应的 FFmpeg 合并命令。
3.执行命令：调用 RunFFmpegCommand 函数，执行合并操作。
4.结果收集：将每个批次合并后的临时文件路径添加到输出集合中，供后续合并使用。通过分批次合并，可以有效管理大规模图片的合并过程，避免一次性处理过多图片导致的资源消耗过大或失败。
6.2 RunFFmpegCommand 函数
Function RunFFmpegCommand(command As String) As Boolean
On Error GoTo ErrorHandler
Dim shell As Object
Set shell = CreateObject("WScript.Shell")
' Use Run method to execute FFmpeg command
' Parameters:
' 0 - Hide window
' True - Wait for command to complete
Dim exitCode As Long
exitCode = shell.run(command, 0, True)
' Check if command executed successfully
If exitCode = 0 Then
RunFFmpegCommand = True
Else
RunFFmpegCommand = False
End If
Exit Function
ErrorHandler:
RunFFmpegCommand = False
End Function功能说明：
* 目的：执行构建好的 FFmpeg 命令，并判断执行是否成功。
* 实现方法：
1.创建 Shell 对象：利用 WScript.Shell 对象执行命令行指令。
2.执行命令：使用 Run 方法执行 FFmpeg 命令，参数设置为隐藏窗口并等待命令完成。
3.结果判断：根据返回的 exitCode 判断命令是否成功执行（0 表示成功）。
4.错误处理：如果执行过程中发生错误，返回 False。该函数确保 FFmpeg 命令的可靠执行，并为合并过程提供反馈。
6.3 RemoveTemporaryFolder 子程序
' Sub to delete temporary folder and its contents
Sub RemoveTemporaryFolder(folderPath As String)
On Error Resume Next
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(folderPath) Then
fso.DeleteFolder folderPath, True
End If
End Sub功能说明：
* 目的：删除指定的临时文件夹及其内容，进行清理操作。
* 实现方法：
* 使用 Scripting.FileSystemObject 对象检查文件夹是否存在，如果存在则删除整个文件夹及其内部所有文件。7. 垂直合并图像，VMergeImagesRecursively 子程序
Sub VMergeImagesRecursively()
Dim ffmpegPath As String
Dim finalOutput As String
Dim imgPaths As Collection
Dim cell As Range
Dim selectedRange As Range
Dim tempFolder As String
Dim tempFilePrefix As String
Dim batchSize As Long
Dim mergedFiles As Collection
Dim maxIterations As Long
Dim currentIteration As Long
Dim logFile As String
Dim logStream As Object
Dim mergeCounter As Long
' Set FFmpeg path
ffmpegPath = ThisWorkbook.Path & "\bin\ffmpeg.exe" ' Modify to the full path of FFmpeg if needed
' Verify FFmpeg exists
If Dir(ffmpegPath) = "" Then
MsgBox "FFmpeg executable not found: " & ffmpegPath, vbCritical
Exit Sub
End If
' Set the final output image path
finalOutput = ThisWorkbook.Path & "\Successful\" & Format(Now, "yyyy_mm_dd_hhmmss") & ".jpg"
If Dir(ThisWorkbook.Path & "\Successful\", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\Successful\"
End If
' Set temporary folder path
tempFolder = ThisWorkbook.Path & "\temp_ffmpeg_merge"
If Dir(tempFolder, vbDirectory) = "" Then
MkDir tempFolder
End If
' Set temporary file prefix
tempFilePrefix = "temp_merge_"
' Set the number of images to merge per batch
batchSize = 4 ' Adjust as needed to reduce the number of iterations
' Initialize the collection to store image paths
Set imgPaths = New Collection
' Initialize log file
logFile = ThisWorkbook.Path & "\merge_log.txt"
Set logStream = CreateObject("Scripting.FileSystemObject").CreateTextFile(logFile, True)
' Initialize merge counter
mergeCounter = 1
' Get the user-selected cell range
On Error Resume Next
Set selectedRange = Application.InputBox("Please select the cell range containing image paths (Column I, starting from I2):", "Select Image Paths", Type:=8)
On Error GoTo 0
If selectedRange Is Nothing Then
MsgBox "No cells selected. Operation canceled.", vbExclamation
logStream.WriteLine "No cells selected. Operation canceled."
logStream.Close
Exit Sub
End If
' Collect image paths
For Each cell In selectedRange
If cell.Column = 9 Then ' Column I is the 9th column
If Trim(cell.Value) <> "" Then
imgPaths.Add cell.Value
End If
End If
Next cell
If imgPaths.Count < 1 Then
MsgBox "No image paths found. Please ensure the selected cells contain valid image paths.", vbExclamation
logStream.WriteLine "No image paths found."
logStream.Close
Exit Sub
End If
' Check if all image files exist
Dim i As Long
For i = 1 To imgPaths.Count
If Dir(imgPaths(i)) = "" Then
MsgBox "Image file not found: " & imgPaths(i), vbCritical
logStream.WriteLine "Image file not found: " & imgPaths(i)
logStream.Close
Exit Sub
End If
Next i
' Log start time and total image count
logStream.WriteLine "Start merging images: " & Now
logStream.WriteLine "Total number of images: " & imgPaths.Count
' Start initial merging
Set mergedFiles = MergeInBatches(imgPaths, ffmpegPath, tempFolder, tempFilePrefix, batchSize, logStream, "vstack", mergeCounter)
' Set maximum number of iterations to prevent infinite loops
maxIterations = 10
currentIteration = 0
' Recursively merge until only one file remains or maximum iterations are reached
Do While mergedFiles.Count > 1 And currentIteration < maxIterations
Set mergedFiles = MergeInBatches(mergedFiles, ffmpegPath, tempFolder, tempFilePrefix, batchSize, logStream, "vstack", mergeCounter)
currentIteration = currentIteration + 1
logStream.WriteLine "Iteration: " & currentIteration & ", Remaining files: " & mergedFiles.Count
Loop
' Check if successfully merged into one file
If mergedFiles.Count = 1 Then
' Convert the final merged PNG to JPG
Dim pngFile As String
pngFile = mergedFiles(1)
' Build FFmpeg command to convert PNG to JPG
Dim convertCmd As String
convertCmd = """" & ffmpegPath & """ -i """ & pngFile & """ -q:v 2 """ & finalOutput & """"
logStream.WriteLine "Converting PNG to JPG: " & convertCmd
' Execute conversion command
If Not ExecuteFFMPEG(convertCmd) Then
MsgBox "Failed to convert final PNG to JPG.", vbCritical
logStream.WriteLine "Failed to convert final PNG to JPG: " & convertCmd
logStream.Close
Exit Sub
End If
' Delete the final PNG file
If Dir(pngFile) <> "" Then
Kill pngFile
logStream.WriteLine "Deleted temporary PNG file: " & pngFile
End If
logStream.WriteLine "Successfully merged images into: " & finalOutput
Else
MsgBox "Merging process did not complete. There may be an issue with the merging steps or it exceeded the maximum number of iterations.", vbCritical
logStream.WriteLine "Merging process did not complete. Final file count: " & mergedFiles.Count
logStream.Close
Exit Sub
End If
' Delete the temporary folder and its contents
DeleteFolder tempFolder
logStream.WriteLine "Deleted temporary folder: " & tempFolder
' Log end time
logStream.WriteLine "Image merging completed: " & Now
logStream.Close
' Notify the user
If Dir(finalOutput) <> "" Then
MsgBox "Images have been successfully merged and saved as: " & finalOutput, vbInformation
Else
MsgBox "Image merging failed. Please check the FFmpeg commands and ensure all image paths are valid.", vbCritical
End If
End Sub功能说明：
* 目的：使用 FFmpeg 工具将选定的多张图片垂直合并为一张图片。
* 实现步骤：
1.FFmpeg 路径设置：指定 FFmpeg 可执行文件的位置。
2.输出路径设置：设置合并后图片的保存路径，文件名包含时间戳。
3.临时文件夹创建：用于存放中间合并生成的临时文件。
4.用户选择图片范围：弹出对话框让用户选择包含图片路径的单元格区域（默认列为 I 列）。
5.图片存在性检查：确保所有选定的图片文件都存在。
6.批量合并：调用 MergeInBatches 函数，将图片分批次合并，直到最终只剩一张合并后的图片。
7.PNG 转 JPG：将最终的 PNG 格式图片转换为 JPG 格式。
8.清理临时文件：删除临时文件夹及其内容。
9.日志记录：记录合并过程中的详细信息，便于后续排查问题。7.1 MergeInBatches 函数
Function MergeInBatches(inputFiles As Collection, ffmpegPath As String, tempFolder As String, tempFilePrefix As String, batchSize As Long, logStream As Object, mergeType As String, ByRef mergeCounter As Long) As Collection
Dim outputFiles As New Collection
Dim i As Long, j As Long
Dim batch As New Collection
Dim tempOutput As String
Dim cmd As String
Dim k As Long
j = 1
For i = 1 To inputFiles.Count
batch.Add inputFiles(i)
If batch.Count = batchSize Or i = inputFiles.Count Then
If batch.Count = 1 Then
' Only one image, no need to merge, directly add to output collection
outputFiles.Add batch(1)
logStream.WriteLine "Batch " & j & ": Single image, skipping merge: " & batch(1)
Else
' Set temporary output file name as PNG to ensure uniqueness
tempOutput = tempFolder & "\" & tempFilePrefix & mergeCounter & ".png"
' Build FFmpeg command
cmd = """" & ffmpegPath & """"
For k = 1 To batch.Count
cmd = cmd & " -i """ & batch(k) & """"
Next k
cmd = cmd & " -filter_complex """ & mergeType & "=inputs=" & batch.Count & """ """ & tempOutput & """"
' Log the command
logStream.WriteLine "Batch " & j & ": Executing FFmpeg command: " & cmd
' Execute FFmpeg command
If Not ExecuteFFMPEG(cmd) Then
MsgBox "Failed to execute FFmpeg command:" & vbCrLf & cmd, vbCritical
logStream.WriteLine "Failed to execute FFmpeg command: " & cmd
Exit Function
Else
logStream.WriteLine "Batch " & j & ": Successfully merged into " & tempOutput
outputFiles.Add tempOutput
mergeCounter = mergeCounter + 1
End If
' Increment batch counter
j = j + 1
End If
' Reset the current batch
Set batch = New Collection
End If
Next i
Set MergeInBatches = outputFiles
End Function功能说明：
* 目的：将输入的图片文件集合分批次进行合并，支持垂直（vstack）或水平（hstack）合并。
* 实现方法：
1.批次处理：根据设定的 batchSize（每批次合并的图片数量），将输入文件集合分成若干批次。
2.FFmpeg 命令构建：为每个批次构建相应的 FFmpeg 合并命令。
3.执行命令：调用 ExecuteFFMPEG 函数，执行合并操作。
4.结果收集：将每个批次合并后的临时文件路径添加到输出集合中，供后续合并使用。7.2 ExecuteFFMPEG 函数
Function ExecuteFFMPEG(cmd As String) As Boolean
On Error GoTo ErrorHandler
Dim wsh As Object
Set wsh = CreateObject("WScript.Shell")
' Use Run method to execute FFmpeg command
' Parameters:
' 0 - Hide window
' True - Wait for command to complete
Dim exitCode As Long
exitCode = wsh.run(cmd, 0, True)
' Check if command executed successfully
If exitCode = 0 Then
ExecuteFFMPEG = True
Else
ExecuteFFMPEG = False
End If
Exit Function
ErrorHandler:
ExecuteFFMPEG = False
End Function功能说明：
*与 RunFFmpegCommand 函数类似，用于执行 FFmpeg 命令并判断执行结果。7.3 DeleteFolder 子程序
Sub DeleteFolder(folderPath As String)
On Error Resume Next
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(folderPath) Then
fso.DeleteFolder folderPath, True
End If
End Sub功能说明：
* 目的：删除指定的文件夹及其内容，类似于 RemoveTemporaryFolder 子程序。8. 执行 FFmpeg 命令
Sub RunFFCommand()
Dim ffmpegPath As String
Dim inputFilePath As String
Dim outputFilePath As String
Dim cmdCommand As String
Dim newFolderPath As String
Dim fileName As String
Dim basePath As String
Dim fullFilePath As String
Dim fso As Object
Dim wsh As Object
Dim execObj As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set wsh = CreateObject("WScript.Shell")
fullFilePath = Cells(2, 1).Value
basePath = Left(fullFilePath, InStrRev(fullFilePath, "\") - 1) & "\"
newFolderPath = basePath & Format(Now, "YYYY_MM_DD_HHMMSS") & "\"
If Not fso.FolderExists(newFolderPath) Then
' 创建新文件夹
fso.CreateFolder newFolderPath
End If
Dim i As Long
Dim w As Long
Dim h As Long
Dim c As Long
ffmpegPath = ThisWorkbook.Path & "\bin\ffmpeg.exe"
For i = 2 To [a65536].End(3).Row
If Len(Cells(i, "B")) = 0 And Len(Cells(i, "E")) = 0 Then
w = 300
End If
If Len(Cells(i, "C")) = 0 And Len(Cells(i, "F")) = 0 Then
h = 300
End If
If Len(Cells(i, "G")) = 0 Then
c = 2
End If
'fileName = Mid(Cells(i, "A").Value, InStrRev(Cells(i, "A").Value, "\") + 1)
fileName = Left(Mid(Cells(i, "A").Value, InStrRev(Cells(i, "A").Value, "\") + 1), InStrRev(Mid(Cells(i, "A").Value, InStrRev(Cells(i, "A").Value, "\") + 1), ".")) & Cells(i, "H").Value
'Debug.Print Left(Mid(Cells(i, "A").Value, InStrRev(Cells(i, "A").Value, "\") + 1), InStrRev(Mid(Cells(i, "A").Value, InStrRev(Cells(i, "A").Value, "\") + 1), ".")) & Cells(i, "H").Value
Cells(i, "I").Value = newFolderPath & fileName
Cells(i, "I").Interior.Color = RGB(146, 208, 80)
inputFilePath = Cells(i, "A").Value
outputFilePath = newFolderPath & fileName
If Len(Cells(i, "E").Value) > 0 Then
w = Cells(i, "E").Value
Else
If Len(Cells(i, "B").Value) > 0 Then
w = Cells(i, "B").Value
End If
End If
If Len(Cells(i, "F").Value) > 0 Then
h = Cells(i, "F").Value
Else
If Len(Cells(i, "C").Value) > 0 Then
h = Cells(i, "C").Value
End If
End If
If Len(Cells(i, "G").Value) > 0 Then
c = Cells(i, "G").Value
End If
cmdCommand = ffmpegPath & " -i """ & inputFilePath & """ -q:v " & c & " -vf scale=" & w & ":" & h & " """ & outputFilePath & """"
'Shell "cmd.exe /c " & cmdCommand, vbHide
wsh.run "cmd.exe /c " & cmdCommand, 0, True
Next
KillFFmpegIfRunning
End Sub
功能说明：
* 目的：根据工作表中设定的参数，使用 FFmpeg 对图片进行缩放和质量调整。
* 实现步骤：
1.FFmpeg 路径设置：指定 FFmpeg 可执行文件的位置。
2.新文件夹创建：根据当前时间戳创建一个新的文件夹，用于存放处理后的图片。
3.遍历图片路径：从工作表的 A 列遍历所有图片路径，根据 B、C、E、F、G 列的值设置缩放参数和质量。
E列和F列可以重新给图片设置宽高，默认-1（保持原来的宽高）
G压缩效果：
2-5 几乎无损压缩，视觉上与原图几乎无差别 大文件
6-15 高质量压缩，适合大多数场景 较小文件
16-25 中等质量，适合对大小要求严格的情况 小文件
26-31 低质量，压缩率极高，但图像质量明显下降 非常小的文件
4.构建 FFmpeg 命令：根据设定的参数，构建相应的 FFmpeg 命令，用于缩放图片和调整质量。
5.执行命令：调用 WScript.Shell 对象执行 FFmpeg 命令，隐藏命令行窗口并等待执行完成。
6.终止 FFmpeg 进程：调用 KillFFmpegIfRunning 子程序，确保所有 FFmpeg 进程都被终止。通过该子程序，用户可以根据需要对图片进行批量缩放和质量调整，生成符合需求的图像文件。
总结
本文详细解析了一段功能强大的Excel VBA脚本，涵盖了图片路径选择、信息获取、格式化、水平和垂直合并以及进程管理等多项功能。通过结合Excel的强大数据处理能力和FFmpeg的高效图像处理能力，该脚本能够显著提升图像处理的效率和准确性。
关键技术点：
- VBA事件驱动编程：
通过双击事件触发特定操作，增强用户交互体验。
- 外部工具集成：
利用FFmpeg实现高效的图像合并和处理，扩展了VBA的功能。
- GDI+ API调用：
通过API获取图片的详细信息，展示了VBA与系统底层的交互能力。
- 错误处理与日志记录：
确保在执行过程中出现问题时，能够及时反馈并记录日志，便于排查。
使用建议：
- 环境准备：
确保FFmpeg已正确安装，并将其可执行文件放置在脚本指定的路径中（如
bin文件夹）。 - 权限设置：
在执行脚本前，确保Excel拥有必要的权限，以访问文件系统和执行外部命令。
- 备份数据：
在批量处理图片前，建议备份原始数据，防止误操作导致数据丢失。
通过合理应用和调整，可以根据自身需求进一步扩展和优化该脚本，实现更加复杂和定制化的图像处理任务。
PS: 如有需求，可在评论区留言！！！
各位看官，创作不易，记得动动发财的小手点个三连！！！