Macro to play a .wav file will

G

glad_ir

Board Regular
Joined
Nov 22, 2020
Messages
146
Office Version
  1. 2010
Platform
  1. Windows
Hi,

I wonder if somebody can help me with this one please.

I am using the code below to run a 5 minute timer when Rectangle 7 is clicked. I would like to trigger a .wav file to play with 5 seconds of the timer left to run to notify the end of the 5 minutes approaching. Is there a way to add to modify the code below to trigger this?

Any help much appreciated!

Thanks,
Iain

VBA Code: 
Sub countdown6()

Dim time As Date
time = Now()

Dim count As Integer
count = 300 'assuming 30 seconds

time = DateAdd("s", count, time)

Do Until time < Now()
DoEvents
ActivePresentation.SlideShowWindow.View.Slide.Shapes("Rectangle 7").TextFrame.TextRange = Format((time - Now()), "nn:ss")
Loop

End Sub
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Maybe you need 2 loops. Untested, but perhaps try
VBA Code: 
Do Until (time -5) < Now()
   DoEvents
   ActivePresentation.SlideShowWindow.View.Slide.Shapes("Rectangle 7").TextFrame.TextRange = Format((time - Now()), "nn:ss")
Loop

'code to play .wav file here

Do Until (time) < Now()
   Do Events
   ActivePresentation.SlideShowWindow.View.Slide.Shapes("Rectangle 7").TextFrame.TextRange = Format((time - Now()), "nn:ss")
Loop
I don't know what effect the playing of the wav file will have in conjunction with Do Events in this case. If the file takes 2 seconds to play, you may find that when done, there are only 3 seconds left for the rectangle display updates.
 
Upvote 0
Solution
Here is an excel workbook example. See if you can adapt the code for PowerPoint.

The code uses a windows timer for better precision and so as not to block the user interface.

File Demo:
CountDownWav.xlsm


1- Place this code in a Standard Module:
VBA Code: 
Option Explicit

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As Long
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As LongPtr, Optional ByVal uFlags As Long) As Long
    Private Declare PtrSafe Function AddAtom Lib "kernel32" Alias "AddAtomA" (ByVal lpString As String) As Integer
    Private Declare PtrSafe Function GetAtomName Lib "kernel32" Alias "GetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function DeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
 #Else
     Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As LongPtr, Optional ByVal uFlags As Long) As Long
    Private Declare Function AddAtom Lib "kernel32" Alias "AddAtomA" (ByVal lpString As String) As Integer
    Private Declare Function GetAtomName Lib "kernel32" Alias "GetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function DeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
#End If

Public bTimerOn As Boolean, bAbort As Boolean

Public Function RunCountDown( _
    ByVal Shp As Shape, _
    ByVal TimerDurationInSeconds As Long, _
    Optional ByVal PlayWavByWhenInSeconds As Long, _
    Optional ByVal WawFilePathName As String _
) As Boolean

    Dim lStartTime As Long, sAtomName As String
 
    If bTimerOn Then MsgBox "Countdown already running.": Exit Function
    If TimerDurationInSeconds <= 0 Then MsgBox "TimerDurationInSeconds must be >0 Secs": Exit Function
    lStartTime = GetTickCount + (TimerDurationInSeconds * 1000&)
    sAtomName = lStartTime & "|" & Shp.Name & "|" & TimerDurationInSeconds & "|" & _
                PlayWavByWhenInSeconds & "|" & WawFilePathName & "|" & Shp.Parent.Name
    Shp.TextFrame2.TextRange.Text = Format((DateAdd("s", TimerDurationInSeconds, Now()) - Now()), "nn:ss")
    Call CountDown(nIDEvent:=AddAtom(sAtomName))
    Call SetTimer(Application.hwnd, AddAtom(sAtomName), 1000&, AddressOf CountDown)
    RunCountDown = True
End Function

Private Sub CountDown( _
    Optional ByVal hwnd As LongPtr, _
    Optional ByVal uMsg As Long, _
    Optional ByVal nIDEvent As LongPtr, _
    Optional ByVal dwTimer As Long _
)

    Dim lStartTime As Long
    Dim sShapeName As String
    Dim lTimerDuration As Long
    Dim lPlayWavBy As Long
    Dim sWawFilePathName As String
    Dim oParentSheet As Worksheet
    Dim sBuffer As String * 256&, lRet As Long
    Dim sAtomName As String, sAtomNameParts() As String
    Dim dtSecsPassed As Date

    On Error Resume Next
    bTimerOn = True
    lRet = GetAtomName(CInt(nIDEvent), sBuffer, Len(sBuffer))
    sAtomName = Left(sBuffer, lRet)
    If Len(sAtomName) Then
        sAtomNameParts = Split(sAtomName, "|")
        lStartTime = CLng(sAtomNameParts(0&))
        sShapeName = sAtomNameParts(1&)
        lTimerDuration = CLng(sAtomNameParts(2&))
        lPlayWavBy = CLng(sAtomNameParts(3&))
        sWawFilePathName = sAtomNameParts(4&)
        Set oParentSheet = Sheets(sAtomNameParts(5&))
    End If
    dtSecsPassed = ((lStartTime - dwTimer) / 1000&) / 24& / 60& / 60&
    If Len(Dir(sWawFilePathName)) Then
        If (DateDiff("s", 0&, dtSecsPassed) <= lPlayWavBy) Or (uMsg = 0& And (lPlayWavBy >= lTimerDuration)) Then
            Call PlayWav(sWawFilePathName)
        End If
    End If
    With oParentSheet.Shapes(sShapeName)
        If uMsg <> 0& Then
            .TextFrame2.TextRange.Text = Format(((dtSecsPassed)), "nn:ss")
        End If
        If DateDiff("s", 0&, dtSecsPassed) = 0& Or bAbort Then
         .TextFrame2.TextRange.Text = Format(0&, "nn:ss")
            Call DeleteAtom(CInt(nIDEvent))
            Call StopTimer(nIDEvent)
        End If
    End With
End Sub

Private Sub StopTimer(ByVal TimerId As LongPtr)
    Call KillTimer(Application.hwnd, TimerId)
    Application.OnTime Now + TimeSerial(0&, 0&, 1&), "StopWav"
    bTimerOn = False: bAbort = False
    Debug.Print "Done!"
End Sub

Private Sub PlayWav(ByVal WavFilePathName As String)
    Const SND_FILENAME = &H20000, SND_ASYNC = &H1, SND_LOOP = &H8
    Call PlaySound(StrPtr(WavFilePathName), SND_ASYNC + SND_FILENAME + SND_LOOP)
End Sub

Private Sub StopWav()
  Call PlaySound(StrPtr(vbNullString))
End Sub


2- Code Usage Example:
VBA Code: 
Sub Test()
  'Start countdown for 5 mins and play wav sound 5 secs before ending.
  'Change the wav file path & name to suit.
  Call RunCountDown(Sheet1.Shapes("Rectangle 7"), 300&, 5&, "C:\test\Ring.wav")
End Sub

Sub Abort()
    bAbort = True
End Sub
 
Last edited:
Upvote 0
Micron said:
Maybe you need 2 loops. Untested, but perhaps try
VBA Code: 
Do Until (time -5) < Now()
   DoEvents
   ActivePresentation.SlideShowWindow.View.Slide.Shapes("Rectangle 7").TextFrame.TextRange = Format((time - Now()), "nn:ss")
Loop

'code to play .wav file here

Do Until (time) < Now()
   Do Events
   ActivePresentation.SlideShowWindow.View.Slide.Shapes("Rectangle 7").TextFrame.TextRange = Format((time - Now()), "nn:ss")
Loop
I don't know what effect the playing of the wav file will have in conjunction with Do Events in this case. If the file takes 2 seconds to play, you may find that when done, there are only 3 seconds left for the rectangle display updates.
Click to expand...
Thank you!
 
Upvote 0
Jaafar Tribak said:
Here is an excel workbook example. See if you can adapt the code for PowerPoint.

The code uses a windows timer for better precision and so as not to block the user interface.

File Demo:
CountDownWav.xlsm


1- Place this code in a Standard Module:
VBA Code: 
Option Explicit

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As Long
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As LongPtr, Optional ByVal uFlags As Long) As Long
    Private Declare PtrSafe Function AddAtom Lib "kernel32" Alias "AddAtomA" (ByVal lpString As String) As Integer
    Private Declare PtrSafe Function GetAtomName Lib "kernel32" Alias "GetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function DeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
 #Else
     Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As LongPtr, Optional ByVal uFlags As Long) As Long
    Private Declare Function AddAtom Lib "kernel32" Alias "AddAtomA" (ByVal lpString As String) As Integer
    Private Declare Function GetAtomName Lib "kernel32" Alias "GetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function DeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
#End If

Public bTimerOn As Boolean, bAbort As Boolean

Public Function RunCountDown( _
    ByVal Shp As Shape, _
    ByVal TimerDurationInSeconds As Long, _
    Optional ByVal PlayWavByWhenInSeconds As Long, _
    Optional ByVal WawFilePathName As String _
) As Boolean

    Dim lStartTime As Long, sAtomName As String
 
    If bTimerOn Then MsgBox "Countdown already running.": Exit Function
    If TimerDurationInSeconds <= 0 Then MsgBox "TimerDurationInSeconds must be >0 Secs": Exit Function
    lStartTime = GetTickCount + (TimerDurationInSeconds * 1000&)
    sAtomName = lStartTime & "|" & Shp.Name & "|" & TimerDurationInSeconds & "|" & _
                PlayWavByWhenInSeconds & "|" & WawFilePathName & "|" & Shp.Parent.Name
    Shp.TextFrame2.TextRange.Text = Format((DateAdd("s", TimerDurationInSeconds, Now()) - Now()), "nn:ss")
    Call CountDown(nIDEvent:=AddAtom(sAtomName))
    Call SetTimer(Application.hwnd, AddAtom(sAtomName), 1000&, AddressOf CountDown)
    RunCountDown = True
End Function

Private Sub CountDown( _
    Optional ByVal hwnd As LongPtr, _
    Optional ByVal uMsg As Long, _
    Optional ByVal nIDEvent As LongPtr, _
    Optional ByVal dwTimer As Long _
)

    Dim lStartTime As Long
    Dim sShapeName As String
    Dim lTimerDuration As Long
    Dim lPlayWavBy As Long
    Dim sWawFilePathName As String
    Dim oParentSheet As Worksheet
    Dim sBuffer As String * 256&, lRet As Long
    Dim sAtomName As String, sAtomNameParts() As String
    Dim dtSecsPassed As Date

    On Error Resume Next
    bTimerOn = True
    lRet = GetAtomName(CInt(nIDEvent), sBuffer, Len(sBuffer))
    sAtomName = Left(sBuffer, lRet)
    If Len(sAtomName) Then
        sAtomNameParts = Split(sAtomName, "|")
        lStartTime = CLng(sAtomNameParts(0&))
        sShapeName = sAtomNameParts(1&)
        lTimerDuration = CLng(sAtomNameParts(2&))
        lPlayWavBy = CLng(sAtomNameParts(3&))
        sWawFilePathName = sAtomNameParts(4&)
        Set oParentSheet = Sheets(sAtomNameParts(5&))
    End If
    dtSecsPassed = ((lStartTime - dwTimer) / 1000&) / 24& / 60& / 60&
    If Len(Dir(sWawFilePathName)) Then
        If (DateDiff("s", 0&, dtSecsPassed) <= lPlayWavBy) Or (uMsg = 0& And (lPlayWavBy >= lTimerDuration)) Then
            Call PlayWav(sWawFilePathName)
        End If
    End If
    With oParentSheet.Shapes(sShapeName)
        If uMsg <> 0& Then
            .TextFrame2.TextRange.Text = Format(((dtSecsPassed)), "nn:ss")
        End If
        If DateDiff("s", 0&, dtSecsPassed) = 0& Or bAbort Then
         .TextFrame2.TextRange.Text = Format(0&, "nn:ss")
            Call DeleteAtom(CInt(nIDEvent))
            Call StopTimer(nIDEvent)
        End If
    End With
End Sub

Private Sub StopTimer(ByVal TimerId As LongPtr)
    Call KillTimer(Application.hwnd, TimerId)
    Application.OnTime Now + TimeSerial(0&, 0&, 1&), "StopWav"
    bTimerOn = False: bAbort = False
    Debug.Print "Done!"
End Sub

Private Sub PlayWav(ByVal WavFilePathName As String)
    Const SND_FILENAME = &H20000, SND_ASYNC = &H1, SND_LOOP = &H8
    Call PlaySound(StrPtr(WavFilePathName), SND_ASYNC + SND_FILENAME + SND_LOOP)
End Sub

Private Sub StopWav()
  Call PlaySound(StrPtr(vbNullString))
End Sub


2- Code Usage Example:
VBA Code: 
Sub Test()
  'Start countdown for 5 mins and play wav sound 5 secs before ending.
  'Change the wav file path & name to suit.
  Call RunCountDown(Sheet1.Shapes("Rectangle 7"), 300&, 5&, "C:\test\Ring.wav")
End Sub

Sub Abort()
    bAbort = True
End Sub
Click to expand...
Thank you!
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
macro to play a vba file
Replies
4
Views
580
glad_ir
G
N
  • Question Question
Infinite loop slideshow
Replies
1
Views
200
Domenic
D
N
  • Question Question
Always open xlsx files in the already-open instance of Excel
Replies
2
Views
383
nevyoung
N
JeffGrant
  • Question Question
Running cmd batch file repeatedly...
Replies
1
Views
603
offthelip
O
J
  • Question Question
another way to speed the macro .
Replies
3
Views
805
Georgiboy
Georgiboy

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top