Temporarily mute sound (like snooze button) if VBA wave file (alarm) is playing

[mhwolog]

Hi, I am using the below code to play a .wav file which acts like a wake up alarm. The .wav file is 8 mins long so that I definitely wake up. But while the alarm/.wav is playing I would like to be able to mute the sound for 30 seconds if the spacebar is pressed (so that I have time to wake up and mute the sound myself).

I am using this code to play the .wav file:

Function Alarm(Cell, Condition)
    Dim WAVFile As String
    'Dim fileaudio As String
    Const SND_ASYNC = &H1
    Const SND_FILENAME = &H20000
    On Error GoTo ErrHandler
    If Evaluate(Cell.Value & Condition) Then
                
        WAVFile = ThisWorkbook.Path & "\Fire Alarm.wav" 'Edit this statement
        Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
        Alarm = True
        Exit Function
    End If
ErrHandler:
    Alarm = False
End Function

And I have found this code which makes it possible to mute sound, but I'm not sure how to link it to pressing the spacebar, and only enable it whilst the wav file is playing, and to get the sound to unmute automatically after 30 seconds.

Option Explicit
Const VK_VOLUME_MUTE = &HAD
Const VK_VOLUME_DOWN = &HAE
Const VK_VOLUME_UP = &HAF


#If  VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else 
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End  If


Sub VolUp()
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 0, 3, 0
End Sub


Sub VolDown()
   keybd_event VK_VOLUME_DOWN, 0, 1, 0
   keybd_event VK_VOLUME_DOWN, 0, 3, 0
End Sub


Sub VolToggle()
   keybd_event VK_VOLUME_MUTE, 0, 1, 0
End Sub

Any help would be appreciated, Thanks!

 

[Logit]

.
You want to use SEND KEYS, a method to 'bind' the spacebar to a specific macro.

Do an internet search for SEND KEYS. Then, have it (once pressed) activate a macro that temporarily shuts off the sound.

Here is a macro that will play a WAV file and also stop it. Hopefully you can incorporate it into your project.

Option Explicit


Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public stopPlaying As Boolean
Sub SomeMacro()
    Dim startTime As Double, execTime As Double
    stopPlaying = False
    startTime = Timer
    '...
    'Your macro
    '...
    DoEvents
    Do Until stopPlaying
        sndPlaySound32 "C:\Windows\Media\Chimes.wav", &H0
        DoEvents
    Loop
End Sub


Sub stopButton_Click()
    stopPlaying = True
    'Hide
End Sub

This line will pause a macro for the time designated : Application.Wait (Now + TimeValue("0:00:01"))
Note that it is presently set for one second.

 

[mhwolog]

I've got this almost sorted; I put in an input box which asks for the answer to a question. The idea is that if the incorrect answer is put in/enter pressed - excel should mute the volume, wait 45 seconds, unmute the volume (like a snooze button) - and then reask the question. The macro should only stop running once the correct answer is entered (i.e. I'm awake and can mute the volume myself).
However, it looks like the 45 second wait and unmute doesn't work, because a new input box pops up as soon as the incorrect answer is entered and the volume toggles to mute. Any ideas how to prevent the input box from popping up again until after the 45 second wait + unmute?

Function Alarm(Cell, Condition)
Dim WAVFile As String
Dim InputQuestion As String
Dim password As Variant


    
    Const SND_ASYNC = &H1
    Const SND_FILENAME = &H20000
    On Error GoTo ErrHandler
    If Evaluate(Cell.Value & Condition) Then
ContinueAlarm:
        WAVFile = ThisWorkbook.Path & "\Fire Alarm.wav" 'Edit this statement
        Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
        Alarm = True


'Keeping looping until you get a valid answer to your question
  Do
    'Retrieve an answer from the user
      myAnswer = Application.InputBox(InputQuestion, "Please enter password", Type:=2)
       Call VolToggle
       Application.Wait (Now + TimeValue("0:00:45"))
       Call VolToggle
  Loop While myAnswer <> "sam"


        Exit Function
    End If
ErrHandler:
    Alarm = False
End Function

Thanks,

 

[Logit]

.
I understand the hesitancy to utilize SEND KEYS. It can be confusing at times.

What about detecting if a key has been pressed in another manner ? Look at this resource first :

https://wellsr.com/vba/2017/excel/GetAsyncKeyState-vba-to-wait-until-a-key-is-pressed/

 

[mhwolog]

Logit,
Did you mean onkey as opposed to send keys?

I still can't quite figure this out. The code all works with spacebar stopping the wav file from playing - but once the sub to play the music is run within the Alarm function -> the spacebar no longer stops the music. Do you have any ideas? Thanks Leon

Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Option Explicit
Const VK_VOLUME_MUTE = &HAD
Const VK_VOLUME_DOWN = &HAE
Const VK_VOLUME_UP = &HAF




#If  VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else 
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End  If


Function Alarm(Cell, Condition)
On Error GoTo ErrHandler
    If Evaluate(Cell.Value & Condition) Then
        Call Play_The_Sound
        Alarm = True
        Exit Function
    End If
ErrHandler:
    Alarm = False
End Function
Sub Play_The_Sound()
Dim i As Integer
  
    Call sndPlaySound("C:\Users\Leon\Dropbox\Fire Alarm orig.wav", 1)
         'Activate spacebar as shortcut to stop music
    Application.OnKey " ", "StopMusic"
    
    'Turn volume all the way up
    For i = 1 To 100
         Call VolUp
    Next i


End Sub


Sub StopMusic()
'Turn off the music
Call sndPlaySound(0, 0)
'Deactivate spacebar as a shortcut
Application.OnKey " "
End Sub


Sub VolUp()
   keybd_event VK_VOLUME_UP, 0, 1, 0
   keybd_event VK_VOLUME_UP, 0, 3, 0
End Sub

 

[Logit]

.
I've looked at this several different ways and I am also unable to get either SendKeys or OnKey to function as expected with the wave file playing. I've done a ton of searching
on the internet however cannot locate any resources that speak to playing a wave file and using either SendKeys or OnKey. If the resource is out there ... I can't find it.

This leads me to abandon either of those methods and select the built-in Combo Key Assignment provided by Excel. In the DEVELOPER tab, click on MACROS. Click on the macro
name for which the Combo Key Assignment will be utilized. In this case (code below) the macro name is "stopButt o n C l i c k2" ... then click OPTIONS. In the small window that
appears you will see the opportunity to select the CTRL key and any other key. In this circumstance I chose CTRL / a . This can be edited to any key combo you desire.

The code is presently set to playing the chosen wave file at 6:30 am. You can edit that time.

When you simultaneously press the CTRL & a keys, the wave playing is paused for 30 seconds. That time as well can be edited if desired. Then it begins playing again / pausing if
you press the Key Combo as many times as you want. Hopefully you won't simply sleep through forever. You permanently stop this process by clicking the STOP key on the sheet.

It is not necessary to press the START key when you open the workbook. The workbook code in ThisWorkbook module is set to auto-start the timer to begin playing at 6:30 am.
That way if you forget to click the START key, the timer will be initiated anyways.

If there is anyone who knows how to use SendKeys or OnKey while playing a wave file, please add to this thread.

Paste in ThisWorkbook module :

Option Explicit

Private Sub Workbook_Open()
    MacroRunAt
End Sub

Paste in a Routine Module :

Option Explicit

Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public stopPlaying As Boolean
Sub startButt*******()
    Dim startTime As Double, execTime As Double
    stopPlaying = False
    startTime = Timer
    '...
    'Your macro
    '...
    DoEvents
    Do Until stopPlaying
        sndPlaySound32 "C:\Windows\Media\Chimes.wav", &H0   '<---  Change wav file path here
    DoEvents
    Loop
    DoEvents
End Sub


Sub stopButt*******()
    stopPlaying = True          '<--- Stops playing wav file permanently Command Button on sheet
    'Hide
End Sub


Sub stopButt*******2()
    stopPlaying = True          '<--- Pauses playing wav file with key combonation CTRL / a
    ScheduleCopyPriceOver
End Sub


Sub ScheduleCopyPriceOver()
Dim TimeToRun
    TimeToRun = Now + TimeValue("00:00:30") '<--- Resumes playing wav file after 30 second pause
    Application.OnTime TimeToRun, "startButt*******"
End Sub


Sub MacroRunAt()
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    Application.OnTime TimeValue("06:30:00"), "startButt*******"     '<--- Starts playing wav file @ 6:30 am
    
    Application.DisplayAlerts = True
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/lJh2JXfiAQib4Bm08V22VVg9pUqdsxpA9Vpvdh1uZd0

 

[mhwolog]

Thank you so much for your time Logit. I also decided to go down another path to get the result, as I needed a simple shortcut to hit snooze; and I needed to link the alarm to an excel worksheet function. This is the vba script, and this is the autohotkey script below. The alarm can be muted as a "snooze" button, with the entry of a correct password turning off the alarm altogether. Every 60 seconds the input box disappears, turns the volume back on, and then the input box reappears.

Function Alarm(Cell, Condition)


Dim strAlarmHTKpath As String, varProc As Variant


On Error GoTo ErrHandler
    If Evaluate(Cell.Value & Condition) Then
        
         strAlarmHTKpath = "C:\users\Leon\dropbox\alarm.exe" 'Your path here


         varProc = Shell(strAlarmHTKpath, 1)
         
         Alarm = True
        
        Exit Function
    End If
ErrHandler:
    Alarm = False
End Function

SoundPlay, C:\Users\Leon\Dropbox\Fire Alarm extended.wav


Restart:
InputBox, password , Enter Password, (your input will be hidden), HIDE, , , , , , 60


If password <> sam
{     SoundGet, master_mute, , mute
      If master_mute = On
      {SoundSet, +10, , mute
      Goto Restart
      }
      else
      {SoundSet +10 
      Goto Restart
      }
}
else
{     Exit App
}

 

[Logit]

.
Glad you worked out a solution.

Cheers !

 

[Jaafar Tribak]

How about this :

Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Const SND_LOOP = &H8
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

Const WAV_FILE_PATH_NAME As String = "C:\Windows\Media\Chimes.wav"  [B][COLOR=#008000]' <== Change WAV file as required here.[/COLOR][/B]
Const SNOOZE_INTERVAL As Long = 10 'Secs  [B][COLOR=#008000]' <== Change snooze duration as required here.[/COLOR][/B]

Sub StartAlarm()
    Application.OnKey " ", "MuteAlarm"
    PlaySoundAPI WAV_FILE_PATH_NAME, ByVal 0&, SND_FILENAME Or SND_ASYNC Or SND_LOOP
End Sub

Sub StopAlarm()
    Call MuteAlarm(Snooze:=False)
End Sub

Sub MuteAlarm(Optional ByVal Snooze As Boolean = True)
    KillTimer Application.hwnd, 0
    PlaySoundAPI vbNullString, 0, 0
    Application.OnKey " "
    If Snooze Then
        Application.OnKey " ", "MuteAlarm"
        SetTimer Application.hwnd, 0, SNOOZE_INTERVAL * 1000, AddressOf StartAlarm
    End If
End Sub

The above should mute the alarm for 10 secs when the space bar is pressed.
To stop the alarm completly, run the StopAlarm macro.

 

[Logit]

.
Jaafar Tribak

Good show Jaarar !!!!!