Change volume of media on PowerPoint on slide change - vba

Question

So I tried this code to gradually lower the volume of background music that's on slide 1 (and playing in the background for the rest of the presentation), but I cannot get it to affect the volume. What am I doing wrong?
Sub OnSlideShowPageChange()
Dim i As Integer
Dim bkgMusic As Shape
Dim bkgVol As Long
Dim inc As Long
i = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
Set bkgMusic = ActivePresentation.Slides(1).Shapes("Opening Theme")
If i = 1 Then
'Do nothing
ElseIf i <> 1 Then
inc = 0.05
For bkgVol = 1 To 0.5
With bkgMusic.MediaFormat
.Volume = bkgVol
End With
bkgVol = bkgVol - inc
Application.Wait(Now + TimeValue("00:00:01"))
Next bkgVol
End If
End Sub

Answer 1

So you want to imitate the 'fade-out' effect in PowerPoint Slide show. Even changing the volume of the sound in the first slide doesn't affect the current volume of the background music.
Here I suggest a different way - using the Windows API called 'MCISendString.' MCISendString provides a variety of ways to control the audio-play.(link) Especially the command(MCISendString setaudio [AUDIO] volume to xxx) can change the volume in real time. Following is an example where the slide show starts playing on the 2nd slide and, on the 6th slide, fades out the audio and stops playing in 3 seconds.
Please take a look and try the following snippet:
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, _
ByVal uReturnLength As Long, ByVal hwndCallback As LongPtr) As Long
Public TimerID As LongPtr
#Else
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public TimerID As Long
#End If
'audio file name(should exist in the current folder)
Const FileName As String = "bensound.mp3"
'where the audio starts to play
Const StartSlide As Long = 2
'where the audio stops playing
Const EndSlide As Long = 6
'how long the fade-out effect will take
Const FadeDuration As Long = 30 '3 sec * 10 interval
'the default volume
Const DefaultVolume As Integer = 150
'timer count
Dim TimerCount As Long
Dim Playing As Boolean
'Show the current position
Private Sub myTimer()
On Error Resume Next
Dim vol As Single
TimerCount = TimerCount + 1
vol = DefaultVolume * (FadeDuration - TimerCount) / FadeDuration
'Debug.Print vol
mciSendString "setaudio SoundFile volume to " & CStr(vol), vbNullString, 0, 0&
If TimerCount >= FadeDuration Then StopAudio
End Sub
Sub PlayAudio()
mciSendString "close all", vbNullString, 0, 0&
'enclose the FileName with Chr(34)s for a long filename with blank characters
mciSendString "Open " & Chr(34) & FileName & Chr(34) & " alias SoundFile", vbNullString, 0, 0&
mciSendString "Play SoundFile", vbNullString, 0, 0&
mciSendString "setaudio SoundFile volume to " & DefaultVolume, vbNullString, 0, 0&
Playing = True
End Sub
Sub FadeOutAudio()
If Playing Then startTimer
End Sub
Sub StopAudio()
mciSendString "Stop SoundFile", vbNullString, 0, 0&
stopTimer
Playing = False
End Sub
Private Sub startTimer()
If TimerID = 0& Then
TimerID = SetTimer(0&, 0&, 100&, AddressOf myTimer) ' 1000 = 1sec, 500 = 0.5sec
End If
End Sub
Private Sub stopTimer()
On Error Resume Next
KillTimer 0&, TimerID
TimerID = 0&
TimerCount = 0
End Sub
Sub onSlideShowTerminate(SSW As SlideShowWindow)
stopTimer
mciSendString "close all", vbNullString, 0, 0&
Playing = False
End Sub
'fires whenever the show page changes
Sub onSlideShowPageChange(SSW As SlideShowWindow)
If SSW.View.Slide.SlideIndex = StartSlide Then
PlayAudio
ElseIf SSW.View.Slide.SlideIndex = EndSlide Then
FadeOutAudio
Else
'
End If
End Sub