Fade volume of background media on specific slide in PowerPoint using VBA

Question

I have a PowerPoint which begins with a a media file automatically playing. The first slide is programmed to transition after 20 seconds, all the while the music keeps playing. I would like for it to keep playing for the duration of the slideshow, but fade to a lower volume once the second slide appears and remain that way for the rest of the presentation. I've looked at this Powerpoint change sound effect volume in macro but it doesn't seem to satisfy my needs.

I tried this:

Sub fadeVolSlideChange(ByVal ShowPos As SlideShowWindow)
    Dim ShowPos As Integer
    Dim bkgMusic As Shape
    Dim Step As Long
    
    ShowPos = ShowPos.View.CurrentShowPosition
    Set bkgMusic = ActiveWindow.Selection.ShapeRange(1)

    If ShowPos = 2 Then
        Set Step = 0.05
        For i = 1 To 0.5
            With bkgMusic.MediaFormat
                .Volume = i
                .Muted = False
            End With
            i = i - Step
            Application.Wait (Now + 0.0000025)
        Next i
    End If

End Sub

With no luck. Thoughts?

Here's the latest edit (still no luck getting it to work):

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.1
            With bkgMusic.MediaFormat
                .Volume = bkgVol
                .Muted = False
            End With
            bkgVol = bkgVol - inc
            Application.Wait (Now + TimeValue("0:00:01"))
        Next bkgVol
    End If
    
End Sub

Wouldn't it be simplest to edit the sound file in something like Audacity (free) to do the fade at the desired time? — Steve Rindsberg
– Steve Rindsberg, Commented Nov 20, 2020 at 17:42
That would be a great option if the file didn’t loop. I’m using the presentation as a game and so the the music would be running continuously for about 50 or so minutes. — codeEnthusiast
– codeEnthusiast, Commented Nov 21, 2020 at 17:04
You might be able to tie the code in the link you posted to a slidechange event, then IF the slide index = 1, bump the volume to full, ELSE lower it. — Steve Rindsberg
– Steve Rindsberg, Commented Nov 22, 2020 at 22:20
You can't make up your own event names; your sub should be named OnSlideShowPageChange ... officeoneonline.com/vba/events_version.html — Steve Rindsberg
– Steve Rindsberg, Commented Nov 25, 2020 at 16:17

Steve Rindsberg · Accepted Answer · 2020-11-27 19:55:47Z

0

This almost works, but PPT shoots us down in the end. After it runs, the volume of the sound file has been reduced, but it doesn't change during the slideshow.

Sub OnSlideShowPageChange()
    Dim i As Integer
    Dim bkgMusic As Shape
    ' This needs to be single, not Long
    Dim bkgVol As Single
    Dim inc As Long
    Dim lCounter As Long
    
    i = ActivePresentation.SlideShowWindow.View.CurrentShowPosition

    Set bkgMusic = ActivePresentation.Slides(1).Shapes("Opening Theme")
    
    If i = 2 Then
        inc = 0.05
        ' Changing the value by fractions so must be a single, not a long, and
        ' decreasing the value requires Step and a negative number:
        For bkgVol = 1 To 0.1 Step -0.1
            With bkgMusic.MediaFormat
                .Volume = bkgVol
                .Muted = False
            End With
            'bkgVol = bkgVol - inc
            ' Application.Wait is not supported in PPT
            'Application.Wait (Now + TimeValue("0:00:01"))
            WaitForIt
            SlideShowWindows(1).View.GotoSlide (2)
        Next bkgVol
    End If
    
End Sub


Sub WaitForIt()

Dim x As Long

For x = 1 To 1000000
    DoEvents
Next
    'MsgBox "Done waiting"
End Sub

answered Nov 27, 2020 at 19:55

Steve Rindsberg

14.9k1 gold badge32 silver badges37 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

codeEnthusiast Over a year ago

So close! Thanks so much for your help.

codeEnthusiast Over a year ago

Just read a little about application events here youpresent.co.uk/powerpoint-application-events-in-vba. Would SlideShowNextSlide work better?

Steve Rindsberg Over a year ago

@codeEnthusiast I doubt it; the code as written does run and actually does change the sound's volume; it's just that PPT doesn't respect the change until you restart the show. And coding SlideShowNextSlide, IIRC, is more complicated, requires an event handler class and code to instantiate it.

konahn · Accepted Answer · 2023-05-15 16:17:51Z

I tried a different method using the windows API called mciSendString and Timer

    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
    
'
Const FileName As String = "sound.mp3"
 
'  
Const StartSlide As Long = 2
 
'
Const EndSlide As Long = 4
 
'
Const FadeDuration As Long = 30     '3 sec * 10 intervals
 
Const DefaultVolume As Integer = 150    '
 
'
Dim TimerCount As Long
 
Dim Playing As Boolean
 
'avoid any possible error
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
    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
 
 
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

(To test the code, you need a sound file 'sound.mp3' in the current folder and at least 4 slides in your PPTx file. )

On Slide 2, the show starts to play 'sound.mp3' and then on slide 4, the sound fades out for 3 seconds. The default volume will be 150%. To make the sound fade out slowly, the timer function repeatedely triggers the MCI command 'setaudio xxx volume to yyy.'

Collectives™ on Stack Overflow

Fade volume of background media on specific slide in PowerPoint using VBA

2 Answers 2

3 Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

3 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related