三流君 ken3のmemo置き場

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

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

XXXXXさんへ ExcelからPowerPoint連続設定 自動画面切り替え 秒数の設定 を Excelから連続で行う VBA マクロ デバッグ

Excel A列に切替タイミングの秒数を入力、PowerPointの画面切り替え タイミングにセットする
そんな処理を行ってみます。

タイトルサムネイル

Youtubeのコメント欄で下記の質問をいただきました

パワーポイントの自動画面切り替えの秒数の設定において、エスセルに記入した秒数を流し込むことは

可能でしょうか。
パワーポイントのスライドが600ページ✖️4セットあり、それぞれ表示する秒数がエクセルにまとめてあ

ります。
これを手打ちしていく作業がなかなか大変なので、効率的な(自動化できる)方法があればご教示いた

だけると更新です。
宜しくお願い致します。

下記、いつもの あのあの 説明動画です
youtu.be
https://youtu.be/QHOxiX9NbDk
目次
00:00 0.やりたいこと
00:50 1.単体テスト SlideShowTransition.AdvanceTime = 5 なとで設定可能
03:55 2.Excelの 切り替え秒数リスト からセットする
09:42 3.蛇足の修正説明

1.単体テスト SlideShowTransition.AdvanceTime = 5 なとで設定可能

VBA powerpoint 画面切り替え タイミング で検索すると、

SlideShowTransition オブジェクト (PowerPoint)
https://docs.microsoft.com/ja-jp/office/vba/api/powerpoint.slideshowtransition
docs.microsoft.com
が見つかり、そこから、

SlideShowTransition.AdvanceOnTime プロパティ (PowerPoint)
https://docs.microsoft.com/ja-jp/office/vba/api/powerpoint.slideshowtransition.advanceontime
一定の時間が経過した後に指定したスライドを自動的に切り替えるかどうかを指定します。 値の取得

と設定が可能です

例
次の使用例は、アクティブなプレゼンテーションのスライド 15— 秒経過した後、またはマウスが

クリックされた後に進むか、最初にマウスがクリックされた場合に設定します。

With ActivePresentation.Slides(1).SlideShowTransition

    .AdvanceOnClick = msoTrue

    .AdvanceOnTime = msoTrue

    .AdvanceTime = 5

End With

↑この公式の例がズバリですね。

イミディエイトでテストしてみた
? ActivePresentation.Slides(1).SlideShowTransition.AdvanceTime
4.25
など、小数の数値でOKみたいですね。
※一瞬、5秒とかなのでDate型で秒数かと思ったが、普通の数値でした。

2.Excelの 切り替え秒数リスト からセットする

ExcelPowerPoint

ここからが、腕の見せ所・・・なんだけど、
いつものように A列に入力された値をセットしてみます。

A1に 切り替え秒数 と見出しを入れといて、
あとは、タテにデータが無くなるまで、
既存パワポ(起動済みのアクティブプレゼン)にセットしてみます。

Option Explicit

Sub Excelで起動済みパワポの切り替え秒数をセット20220508()

    '起動済みのパワポを捕まえる
    Dim ppApp As Object
    
    Set ppApp = Nothing
    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  '忘れないで戻すぞ

    If ppApp Is Nothing Then
        MsgBox "秒数セット用のパワポを開いてから、再テストしてね", vbExclamation
        Exit Sub
    End If
    
    'データをセットする
    Dim r As Range   'Excel 左上
    
    Set r = Range("A1")  'A1からテストで始める
    
    Dim p As Integer  'Excel側:行カウンタ pp:セットするページ
    
    p = 1
    While Len(Trim("" & r.Offset(p, 0))) <> 0  '秒数データがある間ループ
        'ppのセットページがなかったら足りなかったら、Excelのデータが多かったら
        If p > ppApp.ActivePresentation.Slides.Count Then
            'メッセージを出して、数が合わないことを知らせる
            MsgBox "パワポのページが足りません、確認してください", vbExclamation
            Exit Sub  '伝えるだけ伝えて、処理を終了
        End If
        
        'pページのスライド 遷移 SlideShowTransition
        With ppApp.ActivePresentation.Slides(p).SlideShowTransition
            .AdvanceOnClick = msoTrue  'クリック時。
            .AdvanceOnTime = msoTrue   '自動的に切替
            .AdvanceTime = r.Offset(p, 0).Value  '値をそのままセット、文字だったら・・ごめん
        End With
        
        p = p + 1  '次の位置へ
    Wend

    '↑逆に、Excle側のデータが足りない時ってあるの?何かのミスで??
    If p <= ppApp.ActivePresentation.Slides.Count Then 'パワポの方がページ数多かったら?
        'メッセージを出して、数が合わないことを知らせる
        MsgBox "Excelの秒数データが足りません。ページ数とセット数を確認してください"
        Exit Sub  '伝えるだけ伝えて、処理を終了
    End If
    
    '無事終了、やったね
    MsgBox "セット終了"

End Sub

3.蛇足の修正説明

Set r = Range("A1") 'A1からテストで始める
を変更する方法を少々。

Excelのリストに合わせて、
Set r = Range("C3")
など、位置を変えて使ってみてください※使い方を蛇足解説

解決のヒントとなれば幸いです。

Ken3 ホームページ 目次

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



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