ExcelのVBAとPowerPointを使って 楽に動画を作る方法
こんにちは。
このブログは
30代前半の夫婦ふたりで力を合わせて
IT系のスキルアップに役立つ記事を書いていきます。
電気工学・ロボットの分野を学び
会社ではソフトウェア開発に携わっている夫と
ユーザー系システム保守開発の会社で9年弱勤めて
現専業主婦のYukiの
二人で記事を更新しています。
1つ目の記事は
ExcelVBAプログラムを使って
自動でPowerPointのスライドを作り、
動画ファイルにする方法を紹介します。
ExcelやPowerPointは広く使われていて
馴染みのあるアプリですが、
これだけで動画が作れるというのを紹介したくて
作りました。
You Tubeで紹介しています＾＾
動画の中で使用しているVBAのプログラムはこちら↓↓↓
'--- ここから ---
Option Explicit
Public Sub CountDownSlide()
'--- Set Excel Object ---
Dim myWorkBook As Workbook
Dim myWorkSheet As Worksheet
Set myWorkBook = ThisWorkbook
Set myWorkSheet = myWorkBook.Worksheets("カウントダウン")
'--- Set Default Value ---
Dim myFontSize, myLeft, myTop, myWidth, myHeight As Integer
myFontSize = 96
myLeft = 0
myTop = 200
myWidth = 960
myHeight = 200
'--- Set PowerPoint Object ---
Dim myPowerpointApplication As PowerPoint.Application
Set myPowerpointApplication = CreateObject("PowerPoint.Application")
myPowerpointApplication.Visible = True
'--- Create Power Point Presentation ---
Dim myPresentation As Presentation
Set myPresentation = myPowerpointApplication.Presentations.Add
'--- Define Values---
Dim myLayout As CustomLayout
Dim myText, myWaveFile, myPicture As String
Dim i, myMaxRow As Integer
myMaxRow = myWorkSheet.Cells(myWorkSheet.Rows.Count, 1).End(xlUp).Row
'--- 1st Slide ---
With myPresentation
Set myLayout = .SlideMaster.CustomLayouts(7)
Call .Slides.AddSlide(.Slides.Count + 1, myLayout)
myText = myWorkSheet.Range("B2").Value
myPicture = ThisWorkbook.Path + "\..\04_picture\03_背景\" + myWorkSheet.Range("C2").Value
With .Slides(1)
Call .Shapes.AddPicture(FileName:=myPicture, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=myLeft, Top:=myTop, Width:=myWidth, Height:=myHeight).TextFrame.TextRange.Text = myText
.Shapes.Item(.Shapes.Count).TextEffect.FontSize = myFontSize
.Shapes.Item(.Shapes.Count).TextEffect.Alignment = ppAlignCenter
.SlideShowTransition.AdvanceOnTime = msoTrue
.SlideShowTransition.AdvanceTime = 2
End With
End With
'--- 2nd - 4th Slidea ---
myFontSize = 192
myTop = 150
With myPresentation
For i = 1 To myMaxRow - 3
Call .Slides.AddSlide(.Slides.Count + 1, myLayout)
myText = myWorkSheet.Cells(i + 2, 2).Value
myPicture = ThisWorkbook.Path + "\..\04_picture\03_背景\" + myWorkSheet.Cells(i + 2, 3).Value
myWaveFile = ThisWorkbook.Path + "\..\05_voice\01_効果音\" + myWorkSheet.Cells(i + 2, 4).Value
With .Slides(i + 1)
Call .Shapes.AddPicture(FileName:=myPicture, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=myLeft, Top:=myTop, Width:=myWidth, Height:=myHeight).TextFrame.TextRange.Text = myText
.Shapes.Item(.Shapes.Count).TextEffect.FontSize = myFontSize
.Shapes.Item(.Shapes.Count).TextEffect.Alignment = ppAlignCenter
.SlideShowTransition.AdvanceOnTime = msoTrue
.SlideShowTransition.AdvanceTime = 1
Call .Shapes.AddMediaObject2(FileName:=myWaveFile, Left:=1000, Top:=0)
Call .TimeLine.MainSequence.AddEffect(Shape:=.Shapes(.Shapes.Count), effectid:=msoAnimEffectMediaPlay)
With .TimeLine.MainSequence
.Item(.Count).Timing.TriggerType = msoAnimTriggerAfterPrevious
End With
End With
Next
End With
'--- Last Slide ---
myFontSize = 144
myTop = 170
With myPresentation
Set myLayout = .SlideMaster.CustomLayouts(7)
Call .Slides.AddSlide(.Slides.Count + 1, myLayout)
myText = myWorkSheet.Cells(myMaxRow, 2).Value
myPicture = ThisWorkbook.Path + "\..\04_picture\03_背景\" + myWorkSheet.Cells(myMaxRow, 3).Value
myWaveFile = ThisWorkbook.Path + "\..\05_voice\01_効果音\" + myWorkSheet.Cells(myMaxRow, 4).Value
With .Slides(myMaxRow - 1)
Call .Shapes.AddPicture(FileName:=myPicture, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=myLeft, Top:=myTop, Width:=myWidth, Height:=myHeight).TextFrame.TextRange.Text = myText
.Shapes.Item(.Shapes.Count).TextEffect.FontSize = myFontSize
.Shapes.Item(.Shapes.Count).TextEffect.Alignment = ppAlignCenter
Call .Shapes.AddMediaObject2(FileName:=myWaveFile, Left:=1000, Top:=0)
Call .TimeLine.MainSequence.AddEffect(Shape:=.Shapes(.Shapes.Count), effectid:=msoAnimEffectMediaPlay)
With .TimeLine.MainSequence
.Item(.Count).Timing.TriggerType = msoAnimTriggerAfterPrevious
End With
End With
End With
End Sub
Public Sub SaveAsMP4()
'--- Set PowerPoint Object ---
Dim myPowerpointApplication As PowerPoint.Application
Set myPowerpointApplication = CreateObject("PowerPoint.Application")
'--- Save as MP4 File ---
Dim myFileName As String
myFileName = ThisWorkbook.Path + "\..\03_movie\" + "sample1"
Call myPowerpointApplication.ActivePresentation.SaveAs(myFileName, ppSaveAsMP4)
End Sub
'--- ここまで ---
説明にわかりずらいところがあったり
ご意見あればぜひコメントで教えてください。
