[Excel][VBA] セル動画()の試み

0.README.md

[Excel][VBA] セル動画()の試み

まさおじさん@keitai_kaiがエクセルを使っておもしろい方法で動画再生[^1]を試みられていたので、便乗。
ただし、自分の考案した方法だと、Microsoft365のエクセル（最新の状態に更新したもの）限定。
[^1] 要は元となる動画を複数の静止画にして、パタパタ漫画のようにして動画として見せるというもの…なお、元ネタだと、マジのセル画だという……(セルをドットとみなして背景色を設定、シート全体で絵にしている……それを1フレーム1シートにして切り替えて表示なので……)

再生中の模様はこちら

なお、元動画はこちら→Bad Apple!! feat.SEKAI / 25時、ナイトコードで。 × 初音ミク - YouTube

まさおじさんの関連ツイート(ポスト)

• はじまり
• Excel おもちゃ🧸素材生成中
• 『マジで時間と、電気の無駄でした。』
• 『PowerPointのスライド枚数に限界は無い。』
• 自分の方法を参考にした結果

自分の手法の基本的な考え方

Microsoft 365のExcelでは、セル内に画像を埋め込むことができるようになったので、これを利用して

• 全画像をA列にセル内画像として挿入(VBAのSelection.InsertPictureInCellによる)
• 動画を表示するセル（セル結合して適当な大きさにしたもの）に「=INDIRECT("A"&フレーム番号)」のような数式を入れておく

のようにしておき、VBAで参照元（フレーム番号のセル）の値を切り替えていく方法で動画再生を実現。

サンプル

サンプルのワークブック(マクロ有効ワークシート)はこちら

なお、画像や音声ファイルは含んでいないのでご注意を。

適当な動画を複数の静止画(<フレーム番号>.jpg)と音声ファイル(bgm.wav)に変換し、

• ワークブックと同じフォルダ下に音声ファイル
• ワークブックと同じフォルダ下にimageフォルダを作成し、そこに画像ファイル

を置き、InsertImagesを実行すればPlayerシートのA列に画像が反映されて、[▶]ボタン(PlayVideo)で再生できるようになる……かも？

ソースコード

画像埋め込み用

• 標準モジュール: Mod_InsertImages
• クラスモジュール: Cls_FlexCompare

動画再生用

• 標準モジュール: Mod_PlayVideo
• クラスモジュール: Cls_SoundPlayer

Cls_FlexCompare.cls.vba

Option Explicit
' ■ クラスモジュール: FlexCompare
' ArrayListのソート(Sort_2)関数向け比較関数定義
' 【注意】 予め mscorlib.dll (C:\Windows\Microsoft.NET\Framework\<version>\mscorlib.tlb) の参照設定が必要

Implements mscorlib.IComparer

Private CompareMethodName

Public Property Let CompareMethod(ByVal MethodName As String)
    CompareMethodName = MethodName
End Property

Public Function IComparer_Compare(ByVal x, ByVal y) As Long
    IComparer_Compare = Application.Run(CompareMethodName, x, y)
End Function

Cls_SoundPlayer.cls.vba

Option Explicit
' ■ クラスモジュール: Cls_SoundPlayer
' 簡易サウンドプレイヤー

Private Enum MCIERROR
    MCIERR_NO_ERROR = 0
    MCIERR_UNRECOGNIZED_KEYWORD = 259
    MCIERR_UNRECOGNIZED_COMMAND = 261
    MCIERR_HARDWARE = 262
    MCIERR_INVALID_DEVICE_NAME = 263
    MCIERR_OUT_OF_MEMORY = 264
    MCIERR_DEVICE_OPEN = 265
    MCIERR_CANNOT_LOAD_DRIVER = 266
    MCIERR_MISSING_COMMAND_STRING = 267
    MCIERR_PARAM_OVERFLOW = 268
    MCIERR_MISSING_STRING_ARGUMENT = 269
    MCIERR_BAD_INTEGER = 270
    MCIERR_PARSER_INTERNAL = 271
    MCIERR_DRIVER_INTERNAL = 272
    MCIERR_MISSING_PARAMETER = 273
    MCIERR_UNSUPPORTED_FUNCTION = 274
    MCIERR_FILE_NOT_FOUND = 275
    MCIERR_DEVICE_NOT_READY = 276
    MCIERR_INTERNAL = 277
    MCIERR_DRIVER = 278
    MCIERR_CANNOT_USE_ALL = 279
    MCIERR_MULTIPLE = 280
    MCIERR_EXTENSION_NOT_FOUND = 281
    MCIERR_OUTOFRANGE = 282
    MCIERR_FLAGS_NOT_COMPATIBLE = 284
    MCIERR_FILE_NOT_SAVED = 286
    MCIERR_DEVICE_TYPE_REQUIRED = 287
    MCIERR_DEVICE_LOCKED = 288
    MCIERR_DUPLICATE_ALIAS = 289
    MCIERR_BAD_CONSTANT = 290
    MCIERR_MUST_USE_SHAREABLE = 291
    MCIERR_MISSING_DEVICE_NAME = 292
    MCIERR_BAD_TIME_FORMAT = 293
    MCIERR_NO_CLOSING_QUOTE = 294
    MCIERR_DUPLICATE_FLAGS = 295
    MCIERR_INVALID_FILE = 296
    MCIERR_NULL_PARAMETER_BLOCK = 297
    MCIERR_UNNAMED_RESOURCE = 298
    MCIERR_NEW_REQUIRES_ALIAS = 299
    MCIERR_NOTIFY_ON_AUTO_OPEN = 300
    MCIERR_NO_ELEMENT_ALLOWED = 301
    MCIERR_NONAPPLICABLE_FUNCTION = 302
    MCIERR_ILLEGAL_FOR_AUTO_OPEN = 303
    MCIERR_FILENAME_REQUIRED = 304
    MCIERR_EXTRA_CHARACTERS = 305
    MCIERR_DEVICE_NOT_INSTALLED = 306
    MCIERR_GET_CD = 307
    MCIERR_SET_CD = 308
    MCIERR_SET_DRIVE = 309
    MCIERR_DEVICE_LENGTH = 310
    MCIERR_DEVICE_ORD_LENGTH = 311
    MCIERR_NO_INTEGER = 312
    MCIERR_WAVE_OUTPUTSINUSE = 320
    MCIERR_WAVE_SETOUTPUTINUSE = 321
    MCIERR_WAVE_INPUTSINUSE = 322
    MCIERR_WAVE_SETINPUTINUSE = 323
    MCIERR_WAVE_OUTPUTUNSPECIFIED = 324
    MCIERR_WAVE_INPUTUNSPECIFIED = 325
    MCIERR_WAVE_OUTPUTSUNSUITABLE = 326
    MCIERR_WAVE_SETOUTPUTUNSUITABLE = 327
    MCIERR_WAVE_INPUTSUNSUITABLE = 328
    MCIERR_WAVE_SETINPUTUNSUITABLE = 329
    MCIERR_SEQ_DIV_INCOMPATIBLE = 336
    MCIERR_SEQ_PORT_INUSE = 337
    MCIERR_SEQ_PORT_NONEXISTENT = 338
    MCIERR_SEQ_PORT_MAPNODEVICE = 339
    MCIERR_SEQ_PORT_MISCERROR = 340
    MCIERR_SEQ_TIMER = 341
    MCIERR_SEQ_PORTUNSPECIFIED = 342
    MCIERR_SEQ_NOMIDIPRESENT = 343
    MCIERR_NO_WINDOW = 346
    MCIERR_CREATEWINDOW = 347
    MCIERR_FILE_READ = 348
    MCIERR_FILE_WRITE = 349
    MCIERR_NO_IDENTITY = 350
    MCIERR_CUSTOM_DRIVER_BASE = 512
End Enum

Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" ( _
    ByVal lpstrCommand As String, _
    Optional ByVal lpstrReturnString As String = vbNullString, _
    Optional ByVal uReturnLength As Long = 0, _
    Optional ByVal hwndCallback As LongPtr = 0 _
) As Long

Private Const SoundAliasPrefix As String = "VBA-SoundPlayer-"
Private Const MaxSoundAliasNumber As Long = 100

Private SoundAlias As String

Public Function InitSound( _
    ByVal SoundPath As String, _
    Optional ByVal PlayStart As Boolean = True _
) As String
    Call StopSound
    Dim SoundId As Long
    Dim Ret As Long
    ' [備忘] 未使用のaliasを探して割り当て(Cls_SoundPlayerのインスタンスが並列で使用されている場合を想定)
    ' TODO: もっと効率的な割り当て方があるかも？
    For SoundId = 1 To MaxSoundAliasNumber
        SoundAlias = SoundAliasPrefix & SoundId
        Ret = mciSendString("open """ & SoundPath & """ alias " & SoundAlias)
        If Ret <> MCIERR_DUPLICATE_ALIAS Then Exit For
    Next
    If Ret <> 0 Then
        Err.Raise 9999, Description:="Open Failure [Ret] " & Ret & " [SoundAlias] " & SoundAlias & " [SoundPath] " & SoundPath
        SoundAlias = ""
        Exit Function
    End If
    If PlayStart Then Call StartSound
    InitSound = SoundAlias
End Function

Public Sub StartSound()
    If SoundAlias = "" Then Exit Sub
    Call mciSendString("play " & SoundAlias)
End Sub

Public Sub SeekSound(ByVal SeekSec As Double, Optional ByVal PlayStart As Boolean = False)
    If SoundAlias = "" Then Exit Sub
    Call mciSendString("seek " & SoundAlias & " to " & CLng(SeekSec * 1000#))
    If PlayStart Then Call StartSound
End Sub

Public Sub PauseSound()
    If SoundAlias = "" Then Exit Sub
    Call mciSendString("pause " & SoundAlias)
End Sub

Public Sub ResumeSound()
    If SoundAlias = "" Then Exit Sub
    Call mciSendString("resume " & SoundAlias)
End Sub

Public Sub StopSound()
    If SoundAlias = "" Then Exit Sub
    Call mciSendString("stop " & SoundAlias)
    Call mciSendString("close " & SoundAlias)
    SoundAlias = ""
End Sub

Public Sub CloseAllSounds()
    ' [備忘] Cls_SoundPlayerでopenされたすべてのサウンドをclose（VBEによる強制停止時等、正しく再生が停止されなかった場合等の利用を想定）
    ' TODO: もっと効率的なやり方があるかも？
    Dim SoundId As Long
    For SoundId = 1 To MaxSoundAliasNumber
        SoundAlias = SoundAliasPrefix & SoundId
        Call StopSound
    Next
End Sub

Private Sub Class_Terminate()
    Call StopSound
End Sub

Mod_InsertImages.bas.vba

Option Explicit

' ■標準モジュール: Mod_InsertImages
' セル動画()用の画像をワークシートのA列に埋め込み(※Microsoft 365のExcel・Windowsデスクトップ版のみ可)

' ■参照設定
' - Microsoft Scripting Runtime
' - mscorlib.dll (C:\Windows\Microsoft.NET\Framework\<version>\mscorlib.tlb)

Private Const PlayerSheetNameName As String = "Player"
Private Const PlayerFrameBarName As String = "FrameBar" ' フレーム移動用フォームコントロールのスクロールバーの名前
Private Const ImageFolder = "image" ' フレーム画像はThisWorkbook.Path & "\" & ImageFolder下に「<数字(フレーム番号)>.jpg」の名前で置いておくこと

Sub InsertImages()
    ChDir ThisWorkbook.Path
    Dim Fso As FileSystemObject: Set Fso = New FileSystemObject
    Dim FilenameList As mscorlib.ArrayList: Set FilenameList = New mscorlib.ArrayList
    Dim WorkFile As File
    Dim WorkFilename
    For Each WorkFile In Fso.GetFolder(ImageFolder).Files
        WorkFilename = WorkFile.Name
        If (WorkFilename Like "*.jpg") Or (WorkFilename Like "*.png") Or (WorkFilename Like "*.bmp") Then Call FilenameList.Add(WorkFilename)
    Next
    Dim FlexCompare As Cls_FlexCompare: Set FlexCompare = New Cls_FlexCompare: FlexCompare.CompareMethod = "CompareFileNumber"
    Call FilenameList.Sort_2(FlexCompare)
    Dim MaxImageNumber As Long: MaxImageNumber = FilenameList.Count
    Application.ScreenUpdating = False
    Dim TargetSheet As Worksheet: Set TargetSheet = ThisWorkbook.Worksheets(PlayerSheetNameName)
    TargetSheet.Activate
    TargetSheet.Range("A:A").ClearContents
    Dim CurrentCell As Range: Set CurrentCell = TargetSheet.Range("A1")
    Dim ImageNumber As Long
    On Error Resume Next
    For Each WorkFilename In FilenameList
        ImageNumber = ImageNumber + 1
        CurrentCell.Select
        Selection.InsertPictureInCell ImageFolder & "\" & WorkFilename
        Set CurrentCell = CurrentCell.Offset(1, 0)
    Next
    TargetSheet.ScrollBars(PlayerFrameBarName).Max = MaxImageNumber
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

Private Function CompareFileNumber(ByVal x, ByVal y)
    CompareFileNumber = Left(x, InStr(x, ".") - 1) - Left(y, InStr(y, ".") - 1) ' 拡張子を除いたファイル名が整数になっていることを想定
End Function

Mod_PlayVideo.bas.vba

Option Explicit
' ■標準モジュール: Mod_PlayVideo
' セル動画()再生用

Private Const PlayerSheetNameName As String = "Player"
Private Const PlayerFrameBarName As String = "FrameBar"

Private Const DefaultAutoRepeat As Boolean = True
Private Const DefaultFrameRate As Double = 24#
Private Const DefaultSoundFilename As String = "bgm.wav"

Private AutoRepeat As Boolean
Private FrameRate As Double
Private SoundFilename As String

Private NowPlaying As Boolean

Sub PlayVideo()
    Call PlayVideoOpt
End Sub

Sub PlayVideoOpt( _
        Optional ByVal SpecifiedAutoRepeat As Boolean = DefaultAutoRepeat, _
        Optional ByVal SpecifiedFrameRate As Double = DefaultFrameRate, _
        Optional ByVal SpecifiedSoundFilename As String = DefaultSoundFilename _
    )
    If NowPlaying Then Exit Sub
    AutoRepeat = SpecifiedAutoRepeat
    FrameRate = SpecifiedFrameRate
    SoundFilename = SpecifiedSoundFilename
    NowPlaying = True
    Call UpdateFrame
End Sub

Sub StopVideo()
    NowPlaying = False
End Sub

Sub ForceStopSound()
    ' [備忘] 再生中にVBEで停止した場合等に音楽が鳴りっぱなしになってしまう→Cls_SoundPlayerでopenされたものを強制的にすべてclose
    With New Cls_SoundPlayer
        .CloseAllSounds
    End With
End Sub

Private Sub UpdateFrame()
    Static PlayerFrameBar As ScrollBar
    If PlayerFrameBar Is Nothing Then Set PlayerFrameBar = ThisWorkbook.Worksheets(PlayerSheetNameName).ScrollBars(PlayerFrameBarName)
    Static FrameNumberCell As Range
    If FrameNumberCell Is Nothing Then Set FrameNumberCell = ThisWorkbook.Worksheets(PlayerSheetNameName).Range(PlayerFrameBar.LinkedCell)
    Static SoundPlayer As Cls_SoundPlayer
    If SoundPlayer Is Nothing Then Set SoundPlayer = New Cls_SoundPlayer
    Static StartTime As Double
    If Not NowPlaying Then GoTo STOP_PLAY
    Dim IsFirstTime As Boolean
    Dim ElapsedTime As Double
    Dim CurrentFrameNumber As Long
    If StartTime = 0# Then
        IsFirstTime = True
        CurrentFrameNumber = FrameNumberCell.Value
        ElapsedTime = GetElapsedTime(CurrentFrameNumber)
        StartTime = GetTime() - ElapsedTime
    Else
        CurrentFrameNumber = GetFrameNumber(GetTime() - StartTime)
    End If
    FrameNumberCell.Value = Application.Min(CurrentFrameNumber, PlayerFrameBar.Max) ' : Debug.Print "Frame: " & CurrentFrameNumber
    If PlayerFrameBar.Max <= CurrentFrameNumber Then GoTo STOP_PLAY
    If IsFirstTime Then
        Call SoundPlayer.InitSound(ThisWorkbook.Path & "\" & SoundFilename, PlayStart:=False)
        Call SoundPlayer.SeekSound(ElapsedTime, PlayStart:=True)
    End If
    Application.OnTime (GetTime() + 0.01) / 86400#, "UpdateFrame"
    DoEvents
    Exit Sub
STOP_PLAY:
    Call SoundPlayer.StopSound
    StartTime = 0#
    If NowPlaying And AutoRepeat Then
        FrameNumberCell.Value = 1
        Application.OnTime GetTime() / 86400#, "UpdateFrame"
    End If
End Sub

Private Function GetFrameNumber(ByVal ElapsedTime As Double) As Long
    GetFrameNumber = CLng(FrameRate * ElapsedTime + 1)
End Function

Private Function GetElapsedTime(ByVal FrameNumber As Long) As Double
    GetElapsedTime = CDbl(FrameNumber - 1) / FrameRate
End Function

Private Function GetTime() As Double
    GetTime = Date * 84600# + Timer
End Function