カテゴリー: 未分類

’ このサブがボタンクリック時にコールされるように実装してください。
Sub startSlide()
    Dim n           As Long
    sn = ActivePresentation.Slides.Count
    Debug.Print sn
    
    'ActivePresentation.SlideShowSettings.Run
    
    With ActivePresentation.SlideShowSettings
        .RangeType = ppShowSlideRange
        .StartingSlide = 2
        .Run
    End With
    
    ' 1枚目のスライドは開始ボタン用ページなので、２枚目のスライドから開始
    For p = 2 To sn
        'スライド表示と読み上げ開始が若干ずれるので、ウェイトをいれてます。。。
        lag = 2
        start = Timer        
        While Timer < start + lag
            DoEvents
        Wend
        Application.SlideShowWindows(1).View.Next        '次のページ
        n = Application.SlideShowWindows(1).View.CurrentShowPosition
        ret = readText(n)
        
    Next
    
    ' 終わったらスライド１から始まるように初期化
    With ActivePresentation.SlideShowSettings
        .RangeType = ppShowSlideRange
        .StartingSlide = 1
    End With
    
End Sub

’ ノートのテキストを読み上げるファンクション。win10ようなので、ご注意ください。
Function readText(n     As Long) As Boolean
    
    '' ノート欄の文字列を取得
    Dim strNote     As String
    strNote = ActivePresentation.Slides(n).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text
    
    'スライド表示と読み上げ開始が若干ずれるので、ウェイトをいれてます。。。
    lag = 2
    start = Timer
    While Timer < start + lag
        DoEvents
    Wend
    
    '' ノート欄が空の場合は，読み上げ処理を行わずに終了
    If strNote = "" Then
        read = FALSE
    End If
    
    '' 音声合成エンジンを取得
    Dim sv          As Object
    Set sv = CreateObject("SAPI.SpVoice")
    
    '' インストールされている音声合成エンジンのうち、最初に見つかった日本語のものを選択
    For i = 0 To sv.GetVoices.Count - 1
        If InStr(sv.GetVoices.Item(i).GetDescription, "Japanese") Then
            Set sv.Voice = sv.GetVoices.Item(i)
            Exit For
        End If
    Next
    '' 日本語のエンジンが見つからなかった場合
    If InStr(sv.Voice.GetDescription, "Japanese") < 1 Then
        '' 発見に失敗した旨をメッセージボックスで通知
        MsgBox "日本語のエンジンが見つかりませんでした。" & vbCrLf & _
        "現在の設定 : " & sv.Voice.GetDescription
        read = FALSE
    End If
    
    '' 音声合成実行
    sv.Speak strNote
    
    '' 音声合成エンジンを開放
    Set sv = Nothing
    
    read = TRUE
    
End Function