视频压缩，批量插入视频

使用FFmpeg工具压缩视频文件，然后批量插入到Excel中，并确保每个视频对应特定的工作表或单元格位置。

涉及到调用外部命令行工具（FFmpeg）来处理视频文件，以及在Excel中嵌入这些经过压缩的视频。

1. 安装FFmpeg：

确保你的系统上已经安装了FFmpeg，并且它的路径被添加到了系统的环境变量中，以便可以从任何地方通过命令行访问它。

2. 准备数据：

创建一个工作表列出所有需要处理和插入的视频信息，包括原始视频路径、目标视频路径（压缩后的）、工作表名称和单元格位置。

步骤 1: 准备数据

在Excel中创建如下表格：

步骤 2: 编写 VBA 宏

接下来，打开VBA编辑器（按 `Alt + F11`），在“插入”菜单中选择“模块”，然后将下面的代码粘贴进去。

Sub CompressAndInsertVideos()
    Dim ws As Worksheet
    Dim videoListWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim originalPath As String
    Dim compressedPath As String
    Dim targetSheetName As String
    Dim targetCell As Range
    
    ' 设置工作表变量为包含视频列表的工作表
    Set videoListWs = ThisWorkbook.Sheets("视频列表") ' 请根据实际情况修改工作表名称
    
    ' 获取最后一行
    lastRow = videoListWs.Cells(videoListWs.Rows.Count, "A").End(xlUp).Row
    
    ' 循环遍历每一行，从第2行开始（假设第一行为标题）
    For i = 2 To lastRow
        ' 获取当前行的视频路径、目标路径、目标工作表名和单元格位置
        originalPath = videoListWs.Cells(i, 1).Value
        compressedPath = videoListWs.Cells(i, 2).Value
        targetSheetName = videoListWs.Cells(i, 3).Value
        Set targetCell = ThisWorkbook.Sheets(targetSheetName).Range(videoListWs.Cells(i, 4).Value)
        
        ' 压缩视频
        Call CompressVideo(originalPath, compressedPath)
        
        ' 插入压缩后的视频
        Call InsertVideo(compressedPath, targetCell)
    Next i
End Sub

Sub CompressVideo(originalPath As String, compressedPath As String)
    Dim cmd As String
    Dim result As Integer
    
    ' 构造FFmpeg命令
    cmd = "ffmpeg -i """ & originalPath & """ -vcodec libx264 -crf 23 -preset veryfast """ & compressedPath & """"
    
    ' 执行命令
    result = Shell(cmd, vbHide)
    
    ' 等待命令完成
    Do While result <> 0
        DoEvents
        result = GetObject("", "WScript.Shell").Exec("tasklist /FI ""PID eq " & result & """").StdOut.ReadAll
        If InStr(result, "INFO: No tasks are running") > 0 Then Exit Do
    Loop
End Sub

Sub InsertVideo(videoPath As String, targetCell As Range)
    Dim shpOle As Object
    On Error Resume Next
    
    ' 检查视频路径是否存在
    If Dir(videoPath) = "" Then
        MsgBox "找不到视频: " & videoPath, vbExclamation, "错误"
        Exit Sub
    End If
    
    ' 插入视频对象
    Set shpOle = targetCell.Worksheet.OLEObjects.Add(Filename:=videoPath, Link:=False, DisplayAsIcon:=True)
    
    With shpOle
        .Top = targetCell.Top
        .Left = targetCell.Left
        .Width = 100 ' 调整宽度
        .Height = 80 ' 调整高度
        '.Object.Verb xlDoubleClicked ' 如果支持的话，激活播放
    End With
    
    On Error GoTo 0
End Sub

执行宏

保存你的VBA代码后，关闭VBA编辑器，返回到Excel。你可以通过点击“开发工具”选项卡上的“宏”按钮来运行这个宏，或者分配给一个快捷键/按钮来执行。