本文介绍的 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 NextIf Target.Address = "$A$1" ThenCall GetSelectedImagePathsCancel = TrueEnd IfIf Target.Address = "$I$1" ThenCall RunFFCommandCancel = TrueEnd IfIf Left(Target.Address, 2) = "$I" Or Left(Target.Address, 2) = "$A" ThenIf Target.Address <> "$I$1" And Target.Address <> "$A$1" ThenIf Target.Value <> "" ThenCancel = TrueThisWorkbook.FollowHyperlink Address:=Target.ValueEnd IfEnd IfEnd IfIf Target.Address = "$J$1" ThenCall VMergeImagesRecursivelyCancel = TrueEnd IfIf Target.Address = "$K$1" ThenCall HorizontalImageMergerCancel = TrueEnd 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 NextDim objWMI As ObjectDim objProcess As ObjectDim colProcess As Object' 获取WMI服务Set objWMI = GetObject("winmgmts:\\.\root\cimv2")If objWMI Is Nothing ThenExit SubEnd If' 查询进程Set colProcess = objWMI.ExecQuery("Select * from Win32_Process Where Name = 'ffmpeg.exe'")If colProcess.Count = 0 ThenExit SubEnd If' 遍历并终止所有FFmpeg进程For Each objProcess In colProcessobjProcess.TerminateNext
End Sub功能说明：
* 目的：在需要时终止所有正在运行的 FFmpeg 进程，释放系统资源。
* 实现方法：
* 利用 WMI（Windows Management Instrumentation）查询系统中所有名为 ffmpeg.exe 的进程。
* 遍历查询结果，逐个终止这些进程。这种方法确保在执行图像处理任务前，系统中不会有残留的 FFmpeg 进程占用资源，避免潜在的冲突和资源浪费。
3. 工作表格式化，FormatContext 子程序
Sub FormatContext()Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseWith 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 = FalseEnd WithSheets(1).Rows("2:10000").RowHeight = 13.25Sheets(1).Range("B2").SelectSheets(1).Cells.EntireColumn.AutoFitColumns("I:I").ColumnWidth = Columns("A:A").ColumnWidth + 20Application.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub
功能说明：
* 目的：统一格式化工作表，提高可读性和美观度。
* 操作内容：
* 字体设置：使用“宋体”字体，字号为12，取消下划线，自动颜色。
* 边框设置：为范围内的单元格添加连续线条边框，线条颜色为默认。
* 对齐方式：水平左对齐，垂直居中。
* 文本格式：取消自动换行，取消单元格合并。
* 行高与列宽调整：
* 设置第2行到第10000行的行高为13.25。
* 自动调整所有列的宽度以适应内容。
* 将列 I 的宽度设置为列 A 宽度加20，以容纳更长的内容。通过该子程序，可以确保生成的工作表具有统一且专业的外观，便于用户查看和操作。
4. 选择并处理图片路径，GetSelectedImagePaths 子程序
Sub GetSelectedImagePaths()Dim fd As FileDialogDim i As LongDim ws As WorksheetDim 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").Cleari = 2' 遍历选中的文件路径For Each selectedFilePath In .SelectedItems' 写入文件路径到A列ws.Cells(i, 1).Value = selectedFilePathi = i + 1Next selectedFilePathElseExit SubEnd IfEnd WithCall RunGetImageResolutionAsDictionaryCall 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 GdiplusStartupInputGdiplusVersion As LongDebugEventCallback As LongPtrSuppressBackgroundThread As LongSuppressExternalCodecs As Long
End Type
Function GetImageResolutionAsDictionary(ByVal filePath As String) As ObjectDim token As LongPtrDim startupInput As GdiplusStartupInputDim image As LongPtrDim width As Long, height As LongDim status As LongDim fileExt As StringDim resultDict As Object ' 用于存储返回值的字典Dim fso As ObjectDim 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" ThenresultDict("Error") = "Unsupported format: " & fileExtSet GetImageResolutionAsDictionary = resultDictExit FunctionEnd If' 获取文件大小Set fso = CreateObject("Scripting.FileSystemObject")If fso.FileExists(filePath) ThenfileSize = fso.GetFile(filePath).Size ' 获取文件大小ElseresultDict("Error") = "File not found: " & filePathSet GetImageResolutionAsDictionary = resultDictExit FunctionEnd If' 初始化GDI+startupInput.GdiplusVersion = 1status = GdiplusStartup(token, startupInput, 0)If status <> 0 ThenresultDict("Error") = "Error initializing GDI+"Set GetImageResolutionAsDictionary = resultDictExit FunctionEnd If' 加载图片status = GdipCreateBitmapFromFile(StrPtr(filePath), image)If status <> 0 ThenresultDict("Error") = "Error loading image"GdiplusShutdown tokenSet GetImageResolutionAsDictionary = resultDictExit FunctionEnd If' 获取图片宽高GdipGetImageWidth image, widthGdipGetImageHeight image, height' 将结果存储到字典中resultDict("Format") = fileExtresultDict("Width") = widthresultDict("Height") = heightresultDict("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 ObjectDim filePath As StringDim lastRow As LongDim rng1 As RangeDim 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.ValueSet 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 = -1rng1.Offset(0, 5).Value = -1rng1.Offset(0, 6).Value = 2rng1.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 = -1rng1.Offset(0, 5).Value = -1rng1.Offset(0, 6).Value = 2rng1.Offset(0, 7).Value = resolutionDict("Format")End IfEnd IfNext rng1
End Sub功能说明：
* 目的：遍历工作表 A 列中的图片文件路径，调用 GetImageResolutionAsDictionary 函数获取每个图片的详细信息，并将结果写入相邻的列中。
* 实现步骤：
1.遍历 A 列：从第2行开始，遍历所有非空的单元格。
2.获取图片信息：调用 GetImageResolutionAsDictionary 函数，获取每个图片的格式、宽度、高度和大小。
3.结果处理：
* 出错处理：如果获取信息时发生错误（如不支持的格式或文件不存在），将单元格背景颜色设置为红色，并在相关列中标记错误信息。
* 成功处理：将图片的宽度、高度、大小（以MB为单位）和格式写入相应的列中，同时设置其他相关信息。通过该子程序，用户可以直观地在工作表中查看每个图片的详细信息，便于后续的筛选和处理。
6. 水平合并图像，HorizontalImageMerger 子程序
Sub HorizontalImageMerger()Dim ffmpegExecutablePath As StringDim finalMergedImagePath As StringDim imagePaths As CollectionDim currentCell As RangeDim userSelectedRange As RangeDim temporaryFolderPath As StringDim tempFileNamePrefix As StringDim imagesPerBatch As LongDim mergedImageFiles As CollectionDim maximumIterations As LongDim iterationCount As LongDim logFilePath As StringDim logFileStream As ObjectDim uniqueMergeCounter As Long' Set FFmpeg pathffmpegExecutablePath = ThisWorkbook.Path & "\bin\ffmpeg.exe" ' Modify to the full path of FFmpeg if needed' Verify FFmpeg existsIf Dir(ffmpegExecutablePath) = "" ThenMsgBox "FFmpeg executable not found: " & ffmpegExecutablePath, vbCriticalExit SubEnd If' Set the final output image path with timestampfinalMergedImagePath = ThisWorkbook.Path & "\Successful\" & Format(Now, "yyyy_mm_dd_hhmmss") & ".jpg"If Dir(ThisWorkbook.Path & "\Successful\", vbDirectory) = "" ThenMkDir ThisWorkbook.Path & "\Successful\"End If' Set temporary folder pathtemporaryFolderPath = ThisWorkbook.Path & "\temp_ffmpeg_merge"If Dir(temporaryFolderPath, vbDirectory) = "" ThenMkDir temporaryFolderPathEnd If' Set temporary file prefixtempFileNamePrefix = "temp_merge_"' Set the number of images to merge per batchimagesPerBatch = 4 ' Adjust as needed to reduce the number of iterations' Initialize the collection to store image pathsSet imagePaths = New Collection' Initialize log filelogFilePath = ThisWorkbook.Path & "\merge_log.txt"Set logFileStream = CreateObject("Scripting.FileSystemObject").CreateTextFile(logFilePath, True)' Initialize merge counteruniqueMergeCounter = 1' Get the user-selected cell rangeOn Error Resume NextSet userSelectedRange = Application.InputBox("Please select the cell range containing image paths (Column I, starting from I2):", "Select Image Paths", Type:=8)On Error GoTo 0If userSelectedRange Is Nothing ThenMsgBox "No cells selected. Operation canceled.", vbExclamationlogFileStream.WriteLine "No cells selected. Operation canceled."logFileStream.CloseExit SubEnd If' Collect image pathsFor Each currentCell In userSelectedRangeIf currentCell.Column = 9 Then ' Column I is the 9th columnIf Trim(currentCell.Value) <> "" ThenimagePaths.Add currentCell.ValueEnd IfEnd IfNext currentCellIf imagePaths.Count < 1 ThenMsgBox "No image paths found. Please ensure the selected cells contain valid image paths.", vbExclamationlogFileStream.WriteLine "No image paths found."logFileStream.CloseExit SubEnd If' Check if all image files existDim index As LongFor index = 1 To imagePaths.CountIf Dir(imagePaths(index)) = "" ThenMsgBox "Image file not found: " & imagePaths(index), vbCriticallogFileStream.WriteLine "Image file not found: " & imagePaths(index)logFileStream.CloseExit SubEnd IfNext index' Log start time and total image countlogFileStream.WriteLine "Start merging images: " & NowlogFileStream.WriteLine "Total number of images: " & imagePaths.Count' Start initial mergingSet mergedImageFiles = BatchMergeImages(imagePaths, ffmpegExecutablePath, temporaryFolderPath, tempFileNamePrefix, imagesPerBatch, logFileStream, "hstack", uniqueMergeCounter)' Set maximum number of iterations to prevent infinite loopsmaximumIterations = 10iterationCount = 0' Recursively merge until only one file remains or maximum iterations are reachedDo While mergedImageFiles.Count > 1 And iterationCount < maximumIterationsSet mergedImageFiles = BatchMergeImages(mergedImageFiles, ffmpegExecutablePath, temporaryFolderPath, tempFileNamePrefix, imagesPerBatch, logFileStream, "hstack", uniqueMergeCounter)iterationCount = iterationCount + 1logFileStream.WriteLine "Iteration: " & iterationCount & ", Remaining files: " & mergedImageFiles.CountLoop' Check if successfully merged into one fileIf mergedImageFiles.Count = 1 Then' Convert the final merged PNG to JPGDim finalPngFile As StringfinalPngFile = mergedImageFiles(1)' Build FFmpeg command to convert PNG to JPGDim conversionCommand As StringconversionCommand = """" & ffmpegExecutablePath & """ -i """ & finalPngFile & """ -q:v 2 """ & finalMergedImagePath & """"logFileStream.WriteLine "Converting PNG to JPG: " & conversionCommand' Execute conversion commandIf Not RunFFmpegCommand(conversionCommand) ThenMsgBox "Failed to convert final PNG to JPG.", vbCriticallogFileStream.WriteLine "Failed to convert final PNG to JPG: " & conversionCommandlogFileStream.CloseExit SubEnd If' Delete the final PNG fileIf Dir(finalPngFile) <> "" ThenKill finalPngFilelogFileStream.WriteLine "Deleted temporary PNG file: " & finalPngFileEnd IflogFileStream.WriteLine "Successfully merged images into: " & finalMergedImagePathElseMsgBox "Merging process did not complete. There may be an issue with the merging steps or it exceeded the maximum number of iterations.", vbCriticallogFileStream.WriteLine "Merging process did not complete. Final file count: " & mergedImageFiles.CountlogFileStream.CloseExit SubEnd If' Delete the temporary folder and its contentsRemoveTemporaryFolder temporaryFolderPathlogFileStream.WriteLine "Deleted temporary folder: " & temporaryFolderPath' Log end timelogFileStream.WriteLine "Image merging completed: " & NowlogFileStream.Close' Notify the userIf Dir(finalMergedImagePath) <> "" ThenMsgBox "Images have been successfully merged and saved as: " & finalMergedImagePath, vbInformationElseMsgBox "Image merging failed. Please check the FFmpeg commands and ensure all image paths are valid.", vbCriticalEnd 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 CollectionDim outputFiles As New CollectionDim i As Long, batchNumber As LongDim currentBatch As New CollectionDim tempOutputPath As StringDim ffmpegCommand As StringDim j As LongbatchNumber = 1For i = 1 To inputFiles.CountcurrentBatch.Add inputFiles(i)If currentBatch.Count = batchSize Or i = inputFiles.Count ThenIf currentBatch.Count = 1 Then' Only one image, no need to merge, directly add to output collectionoutputFiles.Add currentBatch(1)logStream.WriteLine "Batch " & batchNumber & ": Single image, skipping merge: " & currentBatch(1)Else' Set temporary output file name as PNG to ensure uniquenesstempOutputPath = tempFolder & "\" & tempPrefix & mergeCounter & ".png"' Build FFmpeg commandffmpegCommand = """" & ffmpegPath & """"For j = 1 To currentBatch.CountffmpegCommand = ffmpegCommand & " -i """ & currentBatch(j) & """"Next jffmpegCommand = ffmpegCommand & " -filter_complex """ & mergeType & "=inputs=" & currentBatch.Count & """ """ & tempOutputPath & """"' Log the commandlogStream.WriteLine "Batch " & batchNumber & ": Executing FFmpeg command: " & ffmpegCommand' Execute FFmpeg commandIf Not RunFFmpegCommand(ffmpegCommand) ThenMsgBox "Failed to execute FFmpeg command:" & vbCrLf & ffmpegCommand, vbCriticallogStream.WriteLine "Failed to execute FFmpeg command: " & ffmpegCommandExit FunctionElselogStream.WriteLine "Batch " & batchNumber & ": Successfully merged into " & tempOutputPathoutputFiles.Add tempOutputPathmergeCounter = mergeCounter + 1End If' Increment batch counterbatchNumber = batchNumber + 1End If' Reset the current batchSet currentBatch = New CollectionEnd IfNext iSet BatchMergeImages = outputFiles
End Function功能说明：
* 目的：将输入的图片文件集合分批次进行合并，支持水平（hstack）或垂直（vstack）合并。
* 实现方法：
1.批次处理：根据设定的 batchSize（每批次合并的图片数量），将输入文件集合分成若干批次。
2.FFmpeg 命令构建：为每个批次构建相应的 FFmpeg 合并命令。
3.执行命令：调用 RunFFmpegCommand 函数，执行合并操作。
4.结果收集：将每个批次合并后的临时文件路径添加到输出集合中，供后续合并使用。通过分批次合并，可以有效管理大规模图片的合并过程，避免一次性处理过多图片导致的资源消耗过大或失败。
6.2 RunFFmpegCommand 函数
Function RunFFmpegCommand(command As String) As BooleanOn Error GoTo ErrorHandlerDim shell As ObjectSet shell = CreateObject("WScript.Shell")' Use Run method to execute FFmpeg command' Parameters:' 0 - Hide window' True - Wait for command to completeDim exitCode As LongexitCode = shell.run(command, 0, True)' Check if command executed successfullyIf exitCode = 0 ThenRunFFmpegCommand = TrueElseRunFFmpegCommand = FalseEnd IfExit 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 NextDim fso As ObjectSet fso = CreateObject("Scripting.FileSystemObject")If fso.FolderExists(folderPath) Thenfso.DeleteFolder folderPath, TrueEnd If
End Sub功能说明：
* 目的：删除指定的临时文件夹及其内容，进行清理操作。
* 实现方法：
* 使用 Scripting.FileSystemObject 对象检查文件夹是否存在，如果存在则删除整个文件夹及其内部所有文件。7. 垂直合并图像，VMergeImagesRecursively 子程序
Sub VMergeImagesRecursively()Dim ffmpegPath As StringDim finalOutput As StringDim imgPaths As CollectionDim cell As RangeDim selectedRange As RangeDim tempFolder As StringDim tempFilePrefix As StringDim batchSize As LongDim mergedFiles As CollectionDim maxIterations As LongDim currentIteration As LongDim logFile As StringDim logStream As ObjectDim mergeCounter As Long' Set FFmpeg pathffmpegPath = ThisWorkbook.Path & "\bin\ffmpeg.exe" ' Modify to the full path of FFmpeg if needed' Verify FFmpeg existsIf Dir(ffmpegPath) = "" ThenMsgBox "FFmpeg executable not found: " & ffmpegPath, vbCriticalExit SubEnd If' Set the final output image pathfinalOutput = ThisWorkbook.Path & "\Successful\" & Format(Now, "yyyy_mm_dd_hhmmss") & ".jpg"If Dir(ThisWorkbook.Path & "\Successful\", vbDirectory) = "" ThenMkDir ThisWorkbook.Path & "\Successful\"End If' Set temporary folder pathtempFolder = ThisWorkbook.Path & "\temp_ffmpeg_merge"If Dir(tempFolder, vbDirectory) = "" ThenMkDir tempFolderEnd If' Set temporary file prefixtempFilePrefix = "temp_merge_"' Set the number of images to merge per batchbatchSize = 4 ' Adjust as needed to reduce the number of iterations' Initialize the collection to store image pathsSet imgPaths = New Collection' Initialize log filelogFile = ThisWorkbook.Path & "\merge_log.txt"Set logStream = CreateObject("Scripting.FileSystemObject").CreateTextFile(logFile, True)' Initialize merge countermergeCounter = 1' Get the user-selected cell rangeOn Error Resume NextSet selectedRange = Application.InputBox("Please select the cell range containing image paths (Column I, starting from I2):", "Select Image Paths", Type:=8)On Error GoTo 0If selectedRange Is Nothing ThenMsgBox "No cells selected. Operation canceled.", vbExclamationlogStream.WriteLine "No cells selected. Operation canceled."logStream.CloseExit SubEnd If' Collect image pathsFor Each cell In selectedRangeIf cell.Column = 9 Then ' Column I is the 9th columnIf Trim(cell.Value) <> "" ThenimgPaths.Add cell.ValueEnd IfEnd IfNext cellIf imgPaths.Count < 1 ThenMsgBox "No image paths found. Please ensure the selected cells contain valid image paths.", vbExclamationlogStream.WriteLine "No image paths found."logStream.CloseExit SubEnd If' Check if all image files existDim i As LongFor i = 1 To imgPaths.CountIf Dir(imgPaths(i)) = "" ThenMsgBox "Image file not found: " & imgPaths(i), vbCriticallogStream.WriteLine "Image file not found: " & imgPaths(i)logStream.CloseExit SubEnd IfNext i' Log start time and total image countlogStream.WriteLine "Start merging images: " & NowlogStream.WriteLine "Total number of images: " & imgPaths.Count' Start initial mergingSet mergedFiles = MergeInBatches(imgPaths, ffmpegPath, tempFolder, tempFilePrefix, batchSize, logStream, "vstack", mergeCounter)' Set maximum number of iterations to prevent infinite loopsmaxIterations = 10currentIteration = 0' Recursively merge until only one file remains or maximum iterations are reachedDo While mergedFiles.Count > 1 And currentIteration < maxIterationsSet mergedFiles = MergeInBatches(mergedFiles, ffmpegPath, tempFolder, tempFilePrefix, batchSize, logStream, "vstack", mergeCounter)currentIteration = currentIteration + 1logStream.WriteLine "Iteration: " & currentIteration & ", Remaining files: " & mergedFiles.CountLoop' Check if successfully merged into one fileIf mergedFiles.Count = 1 Then' Convert the final merged PNG to JPGDim pngFile As StringpngFile = mergedFiles(1)' Build FFmpeg command to convert PNG to JPGDim convertCmd As StringconvertCmd = """" & ffmpegPath & """ -i """ & pngFile & """ -q:v 2 """ & finalOutput & """"logStream.WriteLine "Converting PNG to JPG: " & convertCmd' Execute conversion commandIf Not ExecuteFFMPEG(convertCmd) ThenMsgBox "Failed to convert final PNG to JPG.", vbCriticallogStream.WriteLine "Failed to convert final PNG to JPG: " & convertCmdlogStream.CloseExit SubEnd If' Delete the final PNG fileIf Dir(pngFile) <> "" ThenKill pngFilelogStream.WriteLine "Deleted temporary PNG file: " & pngFileEnd IflogStream.WriteLine "Successfully merged images into: " & finalOutputElseMsgBox "Merging process did not complete. There may be an issue with the merging steps or it exceeded the maximum number of iterations.", vbCriticallogStream.WriteLine "Merging process did not complete. Final file count: " & mergedFiles.CountlogStream.CloseExit SubEnd If' Delete the temporary folder and its contentsDeleteFolder tempFolderlogStream.WriteLine "Deleted temporary folder: " & tempFolder' Log end timelogStream.WriteLine "Image merging completed: " & NowlogStream.Close' Notify the userIf Dir(finalOutput) <> "" ThenMsgBox "Images have been successfully merged and saved as: " & finalOutput, vbInformationElseMsgBox "Image merging failed. Please check the FFmpeg commands and ensure all image paths are valid.", vbCriticalEnd 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 CollectionDim outputFiles As New CollectionDim i As Long, j As LongDim batch As New CollectionDim tempOutput As StringDim cmd As StringDim k As Longj = 1For i = 1 To inputFiles.Countbatch.Add inputFiles(i)If batch.Count = batchSize Or i = inputFiles.Count ThenIf batch.Count = 1 Then' Only one image, no need to merge, directly add to output collectionoutputFiles.Add batch(1)logStream.WriteLine "Batch " & j & ": Single image, skipping merge: " & batch(1)Else' Set temporary output file name as PNG to ensure uniquenesstempOutput = tempFolder & "\" & tempFilePrefix & mergeCounter & ".png"' Build FFmpeg commandcmd = """" & ffmpegPath & """"For k = 1 To batch.Countcmd = cmd & " -i """ & batch(k) & """"Next kcmd = cmd & " -filter_complex """ & mergeType & "=inputs=" & batch.Count & """ """ & tempOutput & """"' Log the commandlogStream.WriteLine "Batch " & j & ": Executing FFmpeg command: " & cmd' Execute FFmpeg commandIf Not ExecuteFFMPEG(cmd) ThenMsgBox "Failed to execute FFmpeg command:" & vbCrLf & cmd, vbCriticallogStream.WriteLine "Failed to execute FFmpeg command: " & cmdExit FunctionElselogStream.WriteLine "Batch " & j & ": Successfully merged into " & tempOutputoutputFiles.Add tempOutputmergeCounter = mergeCounter + 1End If' Increment batch counterj = j + 1End If' Reset the current batchSet batch = New CollectionEnd IfNext iSet MergeInBatches = outputFiles
End Function功能说明：
* 目的：将输入的图片文件集合分批次进行合并，支持垂直（vstack）或水平（hstack）合并。
* 实现方法：
1.批次处理：根据设定的 batchSize（每批次合并的图片数量），将输入文件集合分成若干批次。
2.FFmpeg 命令构建：为每个批次构建相应的 FFmpeg 合并命令。
3.执行命令：调用 ExecuteFFMPEG 函数，执行合并操作。
4.结果收集：将每个批次合并后的临时文件路径添加到输出集合中，供后续合并使用。7.2 ExecuteFFMPEG 函数
Function ExecuteFFMPEG(cmd As String) As BooleanOn Error GoTo ErrorHandlerDim wsh As ObjectSet wsh = CreateObject("WScript.Shell")' Use Run method to execute FFmpeg command' Parameters:' 0 - Hide window' True - Wait for command to completeDim exitCode As LongexitCode = wsh.run(cmd, 0, True)' Check if command executed successfullyIf exitCode = 0 ThenExecuteFFMPEG = TrueElseExecuteFFMPEG = FalseEnd IfExit Function
ErrorHandler:ExecuteFFMPEG = False
End Function功能说明：
*与 RunFFmpegCommand 函数类似，用于执行 FFmpeg 命令并判断执行结果。7.3 DeleteFolder 子程序
Sub DeleteFolder(folderPath As String)On Error Resume NextDim fso As ObjectSet fso = CreateObject("Scripting.FileSystemObject")If fso.FolderExists(folderPath) Thenfso.DeleteFolder folderPath, TrueEnd If
End Sub功能说明：
* 目的：删除指定的文件夹及其内容，类似于 RemoveTemporaryFolder 子程序。8. 执行 FFmpeg 命令
Sub RunFFCommand()Dim ffmpegPath As StringDim inputFilePath As StringDim outputFilePath As StringDim cmdCommand As StringDim newFolderPath As StringDim fileName As StringDim basePath As StringDim fullFilePath As StringDim fso As ObjectDim wsh As ObjectDim execObj As ObjectSet fso = CreateObject("Scripting.FileSystemObject")Set wsh = CreateObject("WScript.Shell")fullFilePath = Cells(2, 1).ValuebasePath = Left(fullFilePath, InStrRev(fullFilePath, "\") - 1) & "\"newFolderPath = basePath & Format(Now, "YYYY_MM_DD_HHMMSS") & "\"If Not fso.FolderExists(newFolderPath) Then' 创建新文件夹fso.CreateFolder newFolderPathEnd IfDim i As LongDim w As LongDim h As LongDim c As LongffmpegPath = ThisWorkbook.Path & "\bin\ffmpeg.exe"For i = 2 To [a65536].End(3).RowIf Len(Cells(i, "B")) = 0 And Len(Cells(i, "E")) = 0 Thenw = 300End IfIf Len(Cells(i, "C")) = 0 And Len(Cells(i, "F")) = 0 Thenh = 300End IfIf Len(Cells(i, "G")) = 0 Thenc = 2End 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").ValueCells(i, "I").Value = newFolderPath & fileNameCells(i, "I").Interior.Color = RGB(146, 208, 80)inputFilePath = Cells(i, "A").ValueoutputFilePath = newFolderPath & fileNameIf Len(Cells(i, "E").Value) > 0 Thenw = Cells(i, "E").ValueElseIf Len(Cells(i, "B").Value) > 0 Thenw = Cells(i, "B").ValueEnd IfEnd IfIf Len(Cells(i, "F").Value) > 0 Thenh = Cells(i, "F").ValueElseIf Len(Cells(i, "C").Value) > 0 Thenh = Cells(i, "C").ValueEnd IfEnd IfIf Len(Cells(i, "G").Value) > 0 Thenc = Cells(i, "G").ValueEnd IfcmdCommand = ffmpegPath & " -i """ & inputFilePath & """ -q:v " & c & " -vf scale=" & w & ":" & h & " """ & outputFilePath & """"'Shell "cmd.exe /c " & cmdCommand, vbHidewsh.run "cmd.exe /c " & cmdCommand, 0, TrueNextKillFFmpegIfRunning
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: 如有需求，可在评论区留言！！！
各位看官，创作不易，记得动动发财的小手点个三连！！！