Excel / 使用VBA執行ffmpeg合併圖檔與音檔成為影音檔 4

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77

Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = &HFFFFFFFF

#If Win64 Then
    Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As LongPtr, ByVal bInheritHandle As LongPtr, ByVal dwProcessId As LongPtr) As LongPtr
    Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" _
        (ByVal hHandle As LongPtr, ByVal dwMilliseconds As LongPtr) As LongPtr
#Else
    Private Declare Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    Private Declare Function WaitForSingleObject Lib "kernel32" _
        (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
#End If

' 修改
Public Sub creatVideo2()
    
    r = Sheets(1).Range("B1").End(xlDown).Row
    If r = 1048576 Then
        Exit Sub
    End If
    
    For i = 2 To r
    If Sheets(1).Range("A" & i).Value <> "◎" Then
        If Sheets(1).Range("B" & i).Value <> "" And Sheets(1).Range("C" & i).Value <> "" Then
        
                On Error GoTo CleanUp
            
                Application.DisplayAlerts = False
                Application.ScreenUpdating = False
            
                Dim windowStyle As Integer: windowStyle = 3
                Dim wavName As String, mp4Name As String, imgPath As String
                Dim n As Long, s As String
                Dim pId As LongPtr, pHnd As LongPtr
             
                wavName = Sheets(1).Range("C" & i).Value
                
                n = InStr(1, wavName, ".", vbTextCompare)
                mp4Name = Mid(wavName, 1, n - 1) & ".mp4"
                
                imgPath = Sheets(1).Range("B" & i).Value
            
                Debug.Print mp4Name
                
                
                ' 如果用環境參數在WScript.Shell會無法執行
'                ffmpegFile = "C:\Users\trico\Desktop\ffmpeg\bin\ffmpeg.exe"
                ffmpegFile = "C:\Users\edu\Desktop\yt-dlp\ffmpeg\bin\ffmpeg.exe"
                
            
                ' 建立 ffmpeg 指令
                s = ffmpegFile & " -framerate 1 -i " & imgPath & " -i " & Chr(34) & wavName & Chr(34) & " -f mp4 -c:v libx264 -pix_fmt yuv420p " & Chr(34) & mp4Name & Chr(34)
                Debug.Print s
            
                ' 執行並等待 ffmpeg 完成
                pId = Shell(s, windowStyle)
                pHnd = OpenProcess(SYNCHRONIZE, 0, pId)
            
                If pHnd <> 0 Then
                    WaitForSingleObject pHnd, INFINITE
                    CloseHandle pHnd
                    Debug.Print "輸出:" & mp4Name
                    Sheets(1).Range("A" & i).Value = "◎"
                    Sheets(1).Range("D" & i).Value = mp4Name
                End If
            End If
        End If
    Next

CleanUp:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub