Option Explicit
Sub MAIN_Excel英単語をPowerPoint縦スライド作成()
'1.音声ファイルを先に作成する※本当はループは一回の方がいいけど
Call 台詞から音声ファイルを作る_英語 ' https://www.youtube.com/watch?v=OEQRDtOinmw
'2.PowerPointの縦スライドにデータを転記する
Call PowerPointファイルを作る_データ転記
MsgBox "処理終了 パワポファイルを確認してください"
End Sub
'2.PowerPoint縦スライドを新規作成しデータを転記
'2.1 テキストボックスを作成後、英単語と備考を転記
'2.2 wav ファイルをスライドにセットする
Sub PowerPointファイルを作る_データ転記()
'PowerPointを新規起動
'VBScript で PowerPointを起動 https://ken3memo.hatenablog.com/entry/20100704/1278191560 を参考にしないか・・
Dim oPP As Object 'パワポのアプリケーション
Set oPP = CreateObject("PowerPoint.Application")
oPP.Visible = True '可視にする
'新規プレゼンファイルの追加 https://www.youtube.com/watch?v=5ZQMhv0s9qs
oPP.Presentations.Add WithWindow:=msoTrue '新規プレゼンの追加
'縦のスライドにする https://www.youtube.com/watch?v=pcjlxaZWgnU
oPP.ActivePresentation.PageSetup.SlideOrientation = 2 '2:msoOrientationVertical
'英単語が無くなるまでループ
Dim strFILENAME As String
Dim n As Integer
Dim str台詞 As String
Dim r As Range
Dim objSlide As Object 'Slide
Dim objShape As Object 'Shape
Set r = Range("B5") '表の左上、基準値の場所をセット
For n = 1 To 999 '最大999まで、そんなにいらないか
str台詞 = Trim(r.Offset(n, 2))
If Len(str台詞) = 0 Then
Exit For
End If
'パワポのスライドを追加する https://www.youtube.com/watch?v=0oHFihJNTLo
oPP.ActivePresentation.Slides.Add n, 12 'n枚目のスライド追加 レイアウト12 ppLayoutBlank
'ActiveWindow.Selection.SlideRange.Layout = 12 '12:ppLayoutBlank
Set objSlide = oPP.ActivePresentation.Slides(n) 'スライドをセット
'英単語のセット テキストボックス追加 https://www.youtube.com/watch?v=vcUfWDT8yu4
'msoTextOrientationHorizontal 1 横方向
Set objShape = objSlide.Shapes.AddTextbox(1, Left:=50, Top:=100, Width:=500, Height:=200)
objShape.TextFrame.TextRange.Text = Trim(r.Offset(n, 2)) '英単語
objShape.TextFrame.TextRange.Font.Size = 60
'備考コメントのセット テキストボックス追加
Set objShape = objSlide.Shapes.AddTextbox(1, Left:=50, Top:=300, Width:=500, Height:=200)
objShape.TextFrame.TextRange.Text = Trim(r.Offset(n, 3)) '備考・コメント
objShape.TextFrame.TextRange.Font.Size = 60
'音声ファイル.wavをセット
' https://www.youtube.com/watch?v=xcE23Dw-mks
'wavファイル名をマクロ実行位置\連番+台詞
strFILENAME = ThisWorkbook.Path & "\" & r.Offset(n, 1)
'左上0,0に読み上げ音声の追加
Set objShape = objSlide.Shapes.AddMediaObject2(Filename:=strFILENAME, Left:=0, Top:=0)
'追加したら、読み上げ設定を忘れずにアニメのセッティングってのが不思議だけど
objShape.AnimationSettings.PlaySettings.PlayOnEntry = True
'スライドショーで自動実行させたいので、切り替えタイミングをセット
' https://www.youtube.com/watch?v=QHOxiX9NbDk
With objSlide.SlideShowTransition
.AdvanceOnClick = msoTrue 'クリック時を残さないでもいいんだけど
.AdvanceOnTime = msoTrue '自動実行
.AdvanceTime = 0 '0にすると読み上げ後、次に行くので
End With
Next
End Sub
'1.音声ファイルを先に作成する※本当はループは一回の方がいいけど
'------------------
Sub 台詞から音声ファイルを作る_英語()
Dim strFILENAME As String
Dim n As Integer
Dim str台詞 As String
Dim r As Range
Set r = Range("B5") '表の左上、基準値の場所をセット
For n = 1 To 999 '最大999まで、そんなにいらないか
str台詞 = Trim(r.Offset(n, 2))
If Len(str台詞) = 0 Then
Exit For
End If
'ファイル名をマクロ実行位置\連番+台詞
strFILENAME = ThisWorkbook.Path & "\" & r.Offset(n, 1)
'音声ファイル作成 の サブルーチンを呼ぶ
Debug.Print strFILENAME & " " & str台詞
Call 音声ファイル作成_英語(str台詞, strFILENAME) '英語の読み上げ指定
Next
End Sub
'1.1 wavファイルの作成
'2022/05/16 言語指定を英語 409にしてみた。
Sub 音声ファイル作成_英語(strMOJI As String, wavePath As String)
Dim oFileStream, oVoice 'wavファイルに保存
'音声変換文字列が空白なら終了
If strMOJI = "" Then
Exit Sub
End If
'wavファイルに保存
Const SAFT48kHz16BitStereo = 39
Const SSFMCreateForWrite = 3
Set oFileStream = CreateObject("SAPI.spFileStream")
oFileStream.Format.Type = SAFT48kHz16BitStereo
oFileStream.Open wavePath, SSFMCreateForWrite
Set oVoice = CreateObject("SAPI.spVoice")
Dim US '言語の指定 2022/05/16 テストで英語USにしてみた。
Set US = oVoice.GetVoices("Language=409")(0) '409:英語US
Set oVoice.voice = US
Set oVoice.AudioOutputStream = oFileStream
oVoice.Speak strMOJI '台詞を渡す、話す？
oFileStream.Close
Set oFileStream = Nothing
Set oVoice = Nothing
End Sub
