Skip to content

Instantly share code, notes, and snippets.

@furyutei
Last active May 15, 2024 01:30
Show Gist options
  • Save furyutei/cdf82a0af54abd52b60c837c86653848 to your computer and use it in GitHub Desktop.
Save furyutei/cdf82a0af54abd52b60c837c86653848 to your computer and use it in GitHub Desktop.
[Excel][VBA] セル動画()の試み

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

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

再生中の模様はこちら
image

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

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

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
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
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
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
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment