Verblassen des Volumens von Hintergrundmedien auf einer bestimmten Folie in PowerPoint mithilfe von VBA
Ich habe ein PowerPoint, das mit einer Mediendatei beginnt, die automatisch abgespielt wird. Die erste Folie ist so programmiert, dass sie nach 20 Sekunden wechselt, während die Musik weiter abgespielt wird. Ich möchte, dass es für die Dauer der Diashow weiter abgespielt wird, aber nach dem Erscheinen der zweiten Folie auf eine geringere Lautstärke zurückgeht und für den Rest der Präsentation so bleibt. Ich habe mir diese Lautstärke für Powerpoint-Soundeffekte im Makro angesehen, aber sie scheint meine Anforderungen nicht zu erfüllen.
Ich habe es versucht:
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
Ohne Glück. Gedanken?
Hier ist die neueste Bearbeitung (immer noch kein Glück, dass sie funktioniert):
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
Antworten
Das funktioniert fast , aber PPT schießt uns am Ende nieder. Nach der Ausführung wurde die Lautstärke der Audiodatei verringert, sie ändert sich jedoch während der Diashow nicht.
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