スキルアップ・問題解決なら、モーグにおまかせ！

質問失礼します。
 
vbaで2枚以上の画像を使ってパラパラ漫画を作成することは可能でしょうか？
 
下記の形式で作成を検討しております。
 
ご存知の方、どうぞよろしくお願い致します。
 
画像：JPG、PNG、GIF、SVG
動画：MP4、WEBM、
３Dモデル：GLB、GLTF

追記です。
 
エクセル上で再生させるのではなく、特定の形式に保存してから動かす必要があります。

引用:
可能でしょうか？

ご返信ありがとうございます。
 
画像は私が作成しました。形式はpngです。
 
調べても解決できなかったので、ぱらぱら漫画はできないのかとあきらめていました。
 
ご存知とのことですので、作成手順の概要を教えてもらえませんでしょうか？
 

引用:
パラパラ漫画は、Excel上？

うーん、VBA を利用するメリットが無いような気がします。
単純に、画像が複数あり、それを GIF や 動画として保存を行えるアプリを利用する。
出力されたものを Windows のアプリを利用して、表示するほうがいいと思います。
 
Excel の VBA を経由する意図が気になります＾＾；

vbaで画像を作成した後にパラパラ漫画が作成できると、とても効率的なので、vbaで検討しています。
画像の枚数が多いので、専用アプリは使わない方向で考えています。

パラパラ漫画は、通常、1秒間に、複数枚の画像を表示・・・・30フレームのような表現
しかし、VBAで、1つの画像を読み込むのみ、どのくらいの時間が掛かると思いまうか？
試してみるとよいでしょう。

VBA で画像を作成・・・どのように作成を行っているか教えてほしいです。
 
そうですね、以下のサイトが参考になると思います。
http://www.ken3.org/vba/backno/vba028.html

したい事が良くわかりません。
 
同じ位置（セル）に 、次々と画像を表示し、動画の様に見せる事
　PowerPoint のスライド 画面切り替え の タイミング を 極端に短くし 動画の様に見せる
と思います。
 
それなのに、動画をソースとして入れるのですか？
 
 
とりあえず。。。
 
1.　シート「Sheet1」上の A列の セルの列行の大きさを 画像 の縦横比 に合わせて 調整
2.　表示したい画像ファイルを A列の セル上に 全て配置
3.　別シート上に、表示したい大きさの画像 を配置
4.　3で配置した画像を選択、数式バー に 『=Sheet1!A1』 を入力し Enter
 

Sub Sample()
  Dim obj As Object
  Dim i As Long

  Set obj = Worksheets("Sheet3").Shapes(1).DrawingObject

  For i = 1 To 5　　' 5 は 配置した画像の 最終セルの 行位置
    obj.Formula = "Sheet1!A" & i
    DoEvents
    Application.Wait (Now + TimeValue("00:00:01"))
  Next
  Set obj = Nothing
End Sub

ご回答くださいました皆様ありがとうございます。
 
画像の作成はtaitani様が添付くださった内容と同様です。
 
グラフをパラパラ3〜4枚ほど流れる動画が作成できたらと思っております。
 
画像をpngに保存するところはExcelで作成しておりますが、動画はExcel以外でも大丈夫ですが、vbaで自動化したいです。
 
絵本のページは揃っていて、流れるような形で組み合わせるところで躓いております。
 
一通りご回答したつもりですが、漏れておりましたら、ご指摘くださいm(_ _)m

引用:
グラフをパラパラ3〜4枚ほど流れる動画

引用:
そうですね、以下のサイトが参考になると思います。
http://www.ken3.org/vba/backno/vba028.html

ip8bk さんの引用:
画像の作成はtaitani様が添付くださった内容と同様です。
 
グラフをパラパラ3〜4枚ほど流れる動画が作成できたらと思っております。
 
画像をpngに保存するところはExcelで作成しておりますが、動画はExcel以外でも大丈夫ですが、vbaで自動化したいです。

引用:
動画：MP4、WEBM、
３Dモデル：GLB、GLTF

Sub Sample()
  Dim obj As Object
  Dim i As Long

  Set obj = Worksheets("Sheet2").Shapes(1).DrawingObject

  For i = 1 To 5　　' 5 は 配置した画像の 最終セルの 行位置
    DoEvents
    obj.Formula = "Sheet1!A" & i
    DoEvents
    Application.Wait (Now + TimeValue("00:00:01"))　'1秒間隔で次の画像を表示
  Next
  Set obj = Nothing
End Sub

ご回答ありがとうございます。
説明不足がありましたので、取り急ぎご連絡させていただきます。
 

引用:
また、見せるのが、Excel でも Excel以外 でも 良い と言うことから、
パラパラ漫画（動画）として保存し、Movie として再生する必要はなく、
Excel上で、その様に見せれば良い と認識しました。

Excelは動画アプリ作成ソフトではありません。
そうしたことを求めるのは無駄なことではないですか？
 
"複数の画像を動画にする" などでGoogle検索してください。

引用:
動画の作成はvbaで行い、再生はエクセルではなくアプリで動画再生したいと思います。

やはり難しいようですね。
2~3枚の組み合わせで1000以上作成したかったので、vbaで自動化を検討していましたが、vbaでは難しいようですので、もう少し待って解決策がご提案されないようでしたら、諦めたいと思います。

ご返信ありがとうございます。
形式をご連絡いたします。
 
動画：MP4、WEBM、
３Dモデル：GLB、GLTF
 
 

引用:
どんなアプリを使ってみてもらうんですか？

MP4 であれば PowerPoint で作成できるのでは？
 
1.「挿入」-「フォトアルバム」 にて、フォルダ/写真選択
2.「ファイル」-「エクスポート」-「ビデオの作成」
 
あとは、それを VBA にて実施。
 
 
初心者備忘録
指定したフォルダ内の画像ファイルを一括挿入するPowerPointマクロ
https://www.ka-net.org/blog/?p=8228
 
 
Qiita
PowerPoint VBA で 動画ファイルを作るときの注意
https://qiita.com/takebayashi0612/items/9d179ada3d531c137716
 
あたりを参考に。
必要なら、Excelからオートメーションで操作しても良いでしょう。

ご返信ありがとうございます。
皆様のご指導のおかげで何とか作成できそうですが、MP4に変換する以下のコードでエラーが発生します。
こちらがうまくいけばほぼ成功となりますので、お時間あるときに気になる点ございましたらご指導お願いいたします。
 
エラーが出ているコードとエラーメッセージはこちらです↓
objPPT.SaveAs filename:="sample1000", FileFormat:=39
 
実行時エラー'438':
オブジェクトは、このプロパティまたはメソッドをサポートしていません。
 

Sub sample()
    Dim ppApp As New PowerPoint.Application
    Dim ppPt As Presentation
    Dim ppSlide As Slide
    Dim ppShape As PowerPoint.Shape
    Dim ws As Worksheet
'    ppApp.Visible = True 'PowerPoint2007以前の場合は有効にしてください。
    Set ppPt = ppApp.Presentations.Open(ThisWorkbook.Path & "\sample.pptx")
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For i = 1 To 2
        With ws
            .Range(Cells(1, i * 2 - 1), Cells(1, i * 2)).Copy
            'PasteSpeciaでエラーが出るときは、ここに待ちを作ります。
            Set ppSlide = ppPt.Slides(i) 'スライド番号を指定
            ppSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile, Link:=msoFalse
            Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)
            ppShape.Top = Application.CentimetersToPoints(1) '上位置
            ppShape.Left = Application.CentimetersToPoints(1) '左位置
            ppShape.LockAspectRatio = msoTrue '縦横比を固定
            ppShape.Width = Application.CentimetersToPoints(30) '横幅
            Application.CutCopyMode = False
        End With
    Next
    Dim objPPT As Object
    Set objPPT = CreateObject("PowerPoint.Application")
    objPPT.SaveAs filename:="sample1000", FileFormat:=39
  
'    ppPt.Save
'    ppApp.Quit
    Set ppPt = Nothing
    Set ppApp = Nothing
End Sub

引用:
エラーが出ているコードとエラーメッセージはこちらです↓
objPPT.SaveAs filename:="sample1000", FileFormat:=39
 
実行時エラー'438':
オブジェクトは、このプロパティまたはメソッドをサポートしていません。

Sub TEST()
  'Sheet1の A列 に入れたフォルダパスの Jpeg画像を
  'PPに貼り付け
  '切り替え時間1秒のスライドショーとして 写真と同じフォルダにTEST.MP4として出力

  Dim rng As Excel.Range

  Dim PP  As PowerPoint.Application
  Dim prs As PowerPoint.Presentation
  Dim sld As PowerPoint.Slide
  Dim shp As PowerPoint.Shape

  Dim FSO As Scripting.FileSystemObject
  Dim Fld As Scripting.Folder
  Dim Fil As Scripting.File

  Set PP = CreateObject("PowerPoint.Application")
  Set FSO = CreateObject("Scripting.FileSystemObject")

  For Each rng In Application.Intersect(Worksheets("Sheet1").UsedRange, Worksheets("Sheet1").Range("A:A"))
    If FSO.FolderExists(rng.Value) = True Then
      Set Fld = FSO.GetFolder(rng.Value)
      Set prs = PP.Presentations.Add
      For Each Fil In Fld.Files
        
        'JPEGファイルのみ処理
        Select Case LCase(FSO.GetExtensionName(Fil.Path))
          Case "jpg", "jpeg"
            Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutBlank)
            sld.Select
            Set shp = sld.Shapes.AddPicture(Filename:=Fil.Path, LinkToFile:=False, SaveWithDocument:=True, Left:=0, Top:=0)
            With shp
              .LockAspectRatio = True '縦横比を固定

              '挿入した画像をスライドのサイズに合わせる
              If .Width > .Height Then
                .Width = prs.PageSetup.SlideWidth
              Else
                .Height = prs.PageSetup.SlideHeight
              End If

              .Select
            End With

            '画像をスライド中央に配置
            With PP.ActiveWindow.Selection.ShapeRange
              .Align msoAlignCenters, True
              .Align msoAlignMiddles, True
            End With
        End Select
      Next
      prs.CreateVideo Filename:=Fld.Path & "\TEST.mp4", DefaultSlideDuration:=1, VertResolution:=720, Quality:=80
      PP.Activate
      On Error Resume Next
      Do While PP.Presentations.Count > 0
        Application.Wait (Now + TimeValue("00:00:10"))  '10秒待機
        prs.Saved = False
        prs.Close
      Loop
      On Error GoTo 0
    End If
  Next

  PP.Quit
  Set shp = Nothing
  Set sld = Nothing
  Set prs = Nothing
  Set PP = Nothing

  Set Fil = Nothing
  Set Fld = Nothing
  Set FSO = Nothing
  MsgBox "終了"
End Sub

ご回答ありがとうございます。
下記コードでfalseになってしまいますが、A1セルの値と同じ名前のフォルダの有無を判別されているのでしょうか？
フォルダを作成してみましたが、trueになりません。どこのフォルダの中身を見ているのでしょうか？？
 

If FSO.FolderExists(rng.Value) = True Then

フォルダが存在するか確認する
https://www.moug.net/tech/exvba/0060061.html
を
ご確認ください。

ご回答ありがとうございます。
基礎は理解しておりますが、今回のケースがフルパスではないように見えますので、理解できておりません。
 
また事前準備として、A列と同じ名前のフォルダを用意する必要がありますでしょうか？

引用:
今回のケースがフルパスではないように見えますので、理解できておりません。

引用:
また事前準備として、A列と同じ名前のフォルダを用意する必要がありますでしょうか？

ありがとうございます。
ようやく理解できました。大変遅くなり申し訳ございません。
 
しかし、依然と下記のコードのフルパスが正常に認識されずFalseになってしまいます。
 

 If FSO.FolderExists(rng.Value) = True Then

失礼いたしました。
問題なく動作致しました。
 
あと運用にかんするご質問を2〜3して終了させていただきます（ｍ＿　＿ｍ）