ピタ止め動画を自動で生成する方法【ExcelVBA】

ExcelVBAを使用して、YoutubeShortsやTikTokでよるある、ぴた止め動画を生成していく。

前提として、PowerPoint側は手作業でテンプレートを作っておき

そのPowerPoint側の画像をExcelVBAを使用し差し替えて、CreateVideoメソッドを使用して生成。

要はPowerPointでリンクさせた画像を挿入して置き

その画像をExcelVBAで次の画像と入れ替えて更新していくってことです。

動画が生成されるまで待機するには、FileLen関数を使用して動画のサイズを確認します。

サイズが０の間ループする形をとり、Do While FileLen（動画のファイル名） = 0として

間にDoEventsを使用して、空ループを行い生成まで待機させます。

ShellのNameSpaceは(10)がゴミ箱を示すので、MoveHereメソッドでゴミ箱にアイテムを移動。

引数に移動させたいアイテムを指定することでゴミ箱へポイっとする。

そしたら次の"*.png"のファイルを取得して同じように繰り返していく。

Dir関数はない場合、長さ０の文字列””を返すので長さ０の文字列が返ってきたら

フォルダ内に.pngのファイルがないという判定をして終了する。

ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ

実際に使用したサンプルコード

Option Explicit
Public Sub Sample()

'パワポアプリケーションを新規で生成
Dim pp As New PowerPoint.Application

'プレゼンテーション用の変数を用意
Dim pre As PowerPoint.Presentation

'動画のファイル名用の変数を用意
Dim movieName As String

'画像のファイル名用の変数を用意
Dim imageName As String

'動画のファイル名の番号用
Dim i As Integer
Let i = 1

'シェルアプリケーションを使用できるよう生成
Dim myshell As New Shell32.Shell

'アプリを可視化する
pp.Visible = msoTrue

'.pngの拡張子のファイル名を探しimageNameに入れる
Let imageName = Dir("*.png")

'画像ファイルがある間繰り返す
Do While imageName <> ""

'ファイルの名前をリンクしている名前に変更する
Name imageName As "temp.png"

'指定したプレゼンテーションを開く　→　ここでリンクしている画像が更新される
Set pre = pp.Presentations.Open(ThisWorkbook.Path & "\sample.pptx")

'ファイル名を入れる
Let movieName = ThisWorkbook.Path & "\" & i & ".mp4"

'このブックと同じ場所に動画を生成する
pre.CreateVideo movieName

'動画のサイズを確認する
Do While FileLen(movieName) = 0

    'OSに制御を渡す
    DoEvents

    '1秒待機
    Application.Wait Now + TimeSerial(0, 0, 1)

Loop

'iを1増やす
Let i = i + 1

'プレゼンテーションを閉じる
pre.Close

'使用したファイルをゴミ箱へぽい
myshell.Namespace(10).MoveHere ThisWorkbook.Path & "\temp.png"

'次の.pngの拡張子のファイル名を探しimageNameに入れる
Let imageName = Dir("*.png")

Loop

'パワポアプリを終了する
pp.Quit

End Sub