Excel+VBA+FFmpeg全能图片处理利器：批量选择、调整尺寸、压缩质量、图片合并，水平垂直合并一键搞定！

本文介绍的 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: 如有需求，可在评论区留言！！！

各位看官，创作不易，记得动动发财的小手点个三连！！！