三流君 ken3のmemo置き場

三流プログラマーのメモ書きです。主にVBAやWindowsの話題が多いです

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]

Excel英単語から機械音声付きの縦スライドPowerPointを作る 自動転記マクロのテスト


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

Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。



本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)