Excelに入力された英単語から機械音声を作成し、
PowerPointの縦スライドに転記する
#ExcelVBA #PowerPointVBA #自動転記 #英単語 #縦スライド #マクロ
youtu.be
https://youtu.be/pHpxR_IaJ3M
目次
00:00 0.実行結果
00:53 1.単体の部品説明
06:50 2.不具合
0.実行結果
実行結果を先に見せる
作成結果:
#shorts 英単語をパワポの #縦スライド で作成 #PowerPointVBA #ExcelVBA
https://youtube.com/shorts/NxVO8BSPUKs
#shorts 英文をパワポの #縦スライド で作成 #スライドショー で読ませる #PPAP
https://youtube.com/shorts/pRCneMFl5_o
英文サンプル元、なつかしのPPAPは
youtu.be
https://youtu.be/Cbc_j-dXyuU?t=20
↑白瀬さんの動画だけど・・・昔、流行ったんですね。
1.単体の部品説明
F8で止めて、ステップ実行して、説明する
2.不具合
バグ?ファイル名を10文字にしているので、
長い英単語でバグるね。
ね、じゃなえだろ・・・
NOをプラスして回避
=$C$3&TEXT(B6,"000")&TRIM(LEFT(D6,10))&".wav"
ソースファイル アレンジして使ってみてください(うまく自分に合うように修正してくださいね)
※説明が駆け足だったので、リンク先の動画を見たりして補完してください。
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
関連記事:
ken3memo.hatenablog.com
ken3memo.hatenablog.com
ken3memo.hatenablog.com
ken3memo.hatenablog.com