Made Sound Alert More Than Once

[DaleKeel]

I found this

=IF(U70>=W70,SoundMe(),"")

and it works fine for what I have been doing. Problem is now I need for the sound to alert twice or three times and then stop (after the condition is met). Can anyone help me? Thanks.

For a different situation:
I need an alarm with a different sound than the above sound. Is that possible?

Thanks for your time.

 

[Jaafar Tribak]

If you don't want to pass a wav file to the SoundMe() function and you are just happy with playing the standard vba BEEP then you can use the following improved version :

So now, with the updated function below, you have more flexibility... If you pass in the first argument a correct wav file path, the waw will happily play as expected but if you pass an empty string, the standard vba Beep will play instead.

This will play the chord.wav sound 3 times seperated by 0.5 seconds between each play.
=IF(U70>=W70,SoundMe("C:\windows\media\chord.wav",3,0.5),"")

This will play the standard vba BEEP sound 3 times seperated by 0.5 seconds between each play.
=IF(U70>=W70,SoundMe("",3,0.5),"")


-Updated code in a Standard Module:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As LongPtr, ByVal uFlags As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As Long, ByVal uFlags As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Public Function SoundMe(ByVal SoundFile As String, Optional ByVal HowManyTimes As Integer = 1, Optional ByVal IntervalDurationInSecs As Single = 0.5)

    Const SND_ASYNC = &H1
    Const SND_NODEFAULT = &H2
    Static iCounter As Integer
  
    On Error GoTo ErrHandler
  
    If Len(Dir(SoundFile)) = 0 And Len(SoundFile) Then Exit Function

    For iCounter = 1 To HowManyTimes
        DoEvents
        If Len(SoundFile) = 0 Then
            Beep
        Else
            Call PlaySound(StrPtr(SoundFile), SND_ASYNC)
        End If
        If iCounter >= HowManyTimes Then GoTo ErrHandler
        Call Sleep(IntervalDurationInSecs * 1000)
    Next iCounter
  
    Exit Function
  
ErrHandler:
    iCounter = 0
    Call PlaySound(StrPtr(SoundFile), SND_NODEFAULT)
  
End Function

 

[Logit]

Jaafar :

I am using Excel 2007 and find the code does work as indicated. It does not repeat the sound. What it does do is to compress the sound to a degree
that the delivered product sounds more like a chirp.

 

[Jaafar Tribak]

Hi Logit.

If the waw length is greater than the interval time it gets compressed .

Another issue I discovered after further testing is that the sound is not really ASYNC and blocks the application until the sound is finished. This is despite setting the SND_ASYNC flag.

In order to make the wav play asynchronously, I think it should run inside a timer procedure.

I'll post back later .

 

[DaleKeel]

You are really smart. Thanks Again

This may be totally wrong of me to ask but would yo take a look at another one of my post? No one really gave me a viable solution to it the name of it is - Multiple Stock Tickers from Yahoo Finance.
Thanks if you do and sorry to bother you and I do hope this is not against the forum policies.

 

[DaleKeel]

Sorry does not work completely.
=IF(U99>=W99,SoundMe("C:\windows\media\chord.wav",3,0.5),"") WORKS SOUND REPEATS THREE TIMES AND STOPS
=IF(U70>=W70,SoundMe(),"") DOES NOT WORK HAS PUTS #VALUE! IN CELL IF CONDITION IS MET NO SOUND
=IF(U99>=W99,SoundMe("",3,0.5),"") DOES NOT WORK PUTS 0 IN CELL IF CONDITION IS MET NO SOUND

Again sorry I could not test it completely until today.

 

[Jaafar Tribak]

Sorry for not getting back earlier.

Workbook example

Here is an improved version that plays the wav sound from within a windows timer callback procedure.

This version has the following advantages :

1- Calls to the PlaySound API run asynchronously like in a seperate thread hence excel doesn't get blocked while playing various wavs.
2- The Windows timer runs in a seperate hidden instance of excel ... This is extremly important as it prevents crashing excel should an unhandled error occur while the timer is running.
3- The code reads the wav file duration before playing the sound to make sure that the wav sound is finished playing before the next call.

Issues:
I have designed the code so that if various calls to the PlaySound API happen simultaneously , the last call takes precedence over previous ones... This is in order to avoid cluttering the various sounds.


Public Function SoundMe _
( _
Optional ByVal SoundFile As String, _
Optional ByVal HowManyTimes As Integer = 1, _
Optional ByVal IntervalDurationInSecs As Single = 1 _
) _
As String

The SoundFile argument can take the string "BEEP" to play the default vba beep sound.
If no argument are passed to the SoundMe function then no sound is played.

Some examples:
This will play the wav file 6 times seperated by 1 second between each play If A1>100
It will stop playing if A1<100
IF(A1>100,SoundMe("C:\Windows\Media\Ring05.wav",6,1),SoundMe())

This will play Alarm08.wav 4 times seperated by 2 seconds between each play If A1>100
It will play Ring08.wav 4 times seperated by 1 second between each play if A1<100
=IF(A1>100,SoundMe("C:\Windows\Media\Alarm08.wav",4,2),SoundMe("C:\Windows\Media\Ring08.wav",4,1))

This will play Alarm10.wav 4 times seperated by 1 second between each play If A1>100
It will play BEEP 10 times seperated by 2 seconds between each play if A1<100
=IF(A1>100,SoundMe("C:\Windows\Media\Alarm10.wav",4,1),SoundMe("BEEP",10,2))


1- Code in a Standard Module:

Option Explicit

Private Type RIFFHEADER
    RIFFtag        As String * 4
    Filesize       As Long
    WAVtag         As String * 4
    FMTtag         As String * 4
    FMTsize        As Long
    CompressType   As Integer
    Channels       As Integer
    SampleRate     As Long
    BytesPerSec    As Long
    BytesPerSample As Integer
    BitsPerSample  As Integer
End Type

#If VBA7 Then
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As LongPtr, ByVal uFlags As Long) As Long
    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 AddAtom Lib "kernel32" Alias "AddAtomW" (ByVal lpString As LongPtr) As Integer
    Private Declare PtrSafe Function GetAtomName Lib "kernel32" Alias "GetAtomNameW" (ByVal nAtom As Integer, ByVal lpBuffer As LongPtr, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function FindAtom Lib "kernel32" Alias "FindAtomW" (ByVal lpString As LongPtr) As Integer
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function RegisterActiveObject Lib "oleaut32.dll" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare PtrSafe Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As LongPtr, ppunk As Any) As Long
    Private Declare PtrSafe Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "Ole32" (ByVal lpsz As LongPtr, pclsid As Any) As Long
    Private Declare PtrSafe Function EnumProps Lib "user32" Alias "EnumPropsA" (ByVal hwnd As LongPtr, ByVal lpEnumFunc As LongPtr) As Long
    Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As LongPtr) As Long
#Else
    Private Declare Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundW" (ByVal lpszSoundName As Long, ByVal uFlags As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function AddAtom Lib "kernel32" Alias "AddAtomW" (ByVal lpString As Long) As Integer
    Private Declare Function GetAtomName Lib "kernel32" Alias "GetAtomNameW" (ByVal nAtom As Integer, ByVal lpBuffer As Long, ByVal nSize As Long) As Long
    Private Declare Function FindAtom Lib "kernel32" Alias "FindAtomW" (ByVal lpString As Long) As Integer
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function RegisterActiveObject Lib "oleaut32.dll" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As Long, ppunk As Any) As Long
    Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare Function CLSIDFromString Lib "Ole32" (ByVal lpsz As Long, pclsid As Any) As Long
    Private Declare Function EnumProps Lib "user32" Alias "EnumPropsA" (ByVal hwnd As Long, ByVal lpEnumFunc As Long) As Long
    Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
    Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
#End If
 


Public Sub PlaySoundFromRemoteXLInstance(ByVal SoundFile As String, ByVal HowManyTimes As Integer, IntervalDurationInSecs As Single)
   
    If GetRemoteWorkbook Is Nothing Then
        Call OpenRemoteXLInstance
    End If
   
    If HowManyTimes <= 0 Then HowManyTimes = 1
    If IntervalDurationInSecs < 1 Then IntervalDurationInSecs = 1
    IntervalDurationInSecs = WavDuration(SoundFile) + IntervalDurationInSecs

    GetRemoteWorkbook.Application.Run "RemoteSoundMe", Application.Caller.Address, SoundFile, HowManyTimes, IntervalDurationInSecs
       
End Sub

Private Function RemoteSoundMe(ByVal RangeAddr As String, ByVal SoundFile As String, ByVal HowManyTimes As Integer, ByVal IntervalDurationInSecs As Single)

    If Len(Dir(SoundFile)) = 0 And UCase(SoundFile) <> "BEEP" Then
        Call StopAllSounds
        Exit Function
    End If
   
    Range(RangeAddr).ID = RangeAddr & "||" & SoundFile & "||" & _
    HowManyTimes & "||" & HowManyTimes & "||" & IntervalDurationInSecs
   
    Call StopAllSounds
    Call SetProp(Application.hwnd, "addressof", VBA.CLngPtr(AddressOf TimerProc))
    Call SetTimer(Application.hwnd, AddAtom(StrPtr(Range(RangeAddr).ID)), 0, AddressOf TimerProc)

End Function

#If VBA7 Then
    Private Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
#Else
    Private Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
#End If

    Const SND_ASYNC = &H1
    Const SND_NODEFAULT = &H2
    Const SND_FILENAME = &H20000
   
    Dim SoundMeAttributes() As String, sBuffer As String, lRet As Long   
   
    On Error Resume Next
   
    Call SetProp(Application.hwnd, "__@nIDEvent", nIDEvent)
    Call KillTimer(Application.hwnd, GetProp(Application.hwnd, "__@nIDEvent"))
   
    sBuffer = Space(256)
    lRet = GetAtomName(CLng(GetProp(Application.hwnd, "__@nIDEvent")), StrPtr(sBuffer), Len(sBuffer))
    sBuffer = Left(sBuffer, lRet)
    SoundMeAttributes = Split(sBuffer, "||")
   
    If InStr(1, Range(SoundMeAttributes(0)).ID, "||") Then
        Range(SoundMeAttributes(0)).ID = ""
        Range(SoundMeAttributes(0)).ID = SoundMeAttributes(3)
    End If
   
    If Len(SoundMeAttributes(1)) = 0 Then
        GoTo ErrHandler
    Else
        If UCase(SoundMeAttributes(1)) = "BEEP" Then
            Call Beep
        Else
            Call PlaySound(StrPtr(SoundMeAttributes(1)), SND_ASYNC + SND_FILENAME)
        End If
    End If
   
    Range(SoundMeAttributes(0)).ID = Range(SoundMeAttributes(0)).ID - 1
    If Range(SoundMeAttributes(0)).ID = 0 Then
        GoTo ErrHandler
    End If
    Call SetTimer(Application.hwnd, FindAtom(StrPtr(sBuffer)), SoundMeAttributes(4) * 1000, GetProp(Application.hwnd, "addressof"))
   
    Exit Sub

ErrHandler:

    Call KillTimer(Application.hwnd, GetProp(Application.hwnd, "__@nIDEvent"))
    Call PlaySound(StrPtr(SoundMeAttributes(1)), SND_ASYNC + SND_NODEFAULT)
    Range(SoundMeAttributes(0)).ID = ""

End Sub

Private Function WavDuration(ByVal FName As String) As Long

    Dim WAVHEADER As RIFFHEADER, iFnum As Integer
   
    iFnum = FreeFile
    If Len(FName) = 0 Or Dir$(FName) = "" Then Exit Function
   
    Open FName For Binary As iFnum
        Get #iFnum, 1, WAVHEADER
    Close #iFnum
   
    With WAVHEADER
    If .FMTtag <> "fmt " Then Exit Function
        WavDuration = .Filesize \ .BytesPerSec
    End With

End Function

Private Function GetRemoteWorkbook() As Workbook

    Dim pUnk As IUnknown, ClassID(0 To 3) As Long
   
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call GetActiveObject(ClassID(0), 0, pUnk)
   
    If Not pUnk Is Nothing Then
        Set GetRemoteWorkbook = pUnk
        Set pUnk = Nothing
    End If
       
End Function

Private Sub OpenRemoteXLInstance()

    Dim oRemoteXl  As Excel.Application, oWb As Workbook, oBlankWb As Workbook
   
    If GetProp(Application.hwnd, "SecondInstanceRunning") = 0 Then
            Set oRemoteXl = New Excel.Application
            If Not oRemoteXl Is Nothing Then
            Call SetProp(Application.hwnd, "SecondInstanceRunning", 1)
            With oRemoteXl
                .EnableEvents = False
                Set oBlankWb = .Workbooks.Add
                .Calculation = xlCalculationManual
                oBlankWb.Close False
                Set oWb = .Workbooks.Open(ThisWorkbook.FullName, False, True)
                .Calculation = xlCalculationManual
                .Run "AddToROT"
            End With
        End If
    End If
   
End Sub

Private Sub CloseRemoteXLInstance()

    On Error Resume Next
    If Not GetRemoteWorkbook Is Nothing Then
        GetRemoteWorkbook.Saved = True
        GetRemoteWorkbook.Application.Quit
    End If
    Call RemoveProp(Application.hwnd, "SecondInstanceRunning")
    Call RemoveProp(GetDesktopWindow, "OleId")

End Sub

Private Sub AddToROT()

    Const ACTIVEOBJECT_WEAK = 1
    Dim ClassID(0 To 3) As Long, lOleId As Long

    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call RegisterActiveObject(ThisWorkbook, ClassID(0), ACTIVEOBJECT_WEAK, lOleId)
    Call SetProp(GetDesktopWindow, "OleId", lOleId)

End Sub

Private Sub RemoveFromROT()
    Call RevokeActiveObject(CLng(GetProp(GetDesktopWindow, "OleId")), 0)
End Sub

Private Sub StopAllSounds()
    Call EnumProps(Application.hwnd, AddressOf PropEnumProc)
End Sub

#If Win64 Then
    Private Function PropEnumProc(ByVal hwnd As LongPtr, ByVal lpszString As LongPtr, ByVal hData As LongPtr) As Boolean
#Else
    Private Function PropEnumProc(ByVal hwnd As Long, ByVal lpszString As Long, ByVal hData As Long) As Boolean
#End If

    Dim sPropName As String, lRet As Long, lStringLen As Long, iNullCharPos As Integer

    lStringLen = lstrlen(lpszString)
    sPropName = String$(lStringLen + 1, vbNullChar)
    lRet = lstrcpy(ByVal sPropName, lpszString)
    iNullCharPos = InStr(1, sPropName, vbNullChar)
   
    If iNullCharPos > 0 Then
        sPropName = Left(sPropName, iNullCharPos - 1)
    End If
   
    If Left(sPropName, 3) = "__@" Then
        Call KillTimer(Application.hwnd, GetProp(Application.hwnd, sPropName))
        Call RemoveProp(Application.hwnd, sPropName)
    End If
   
    PropEnumProc = True
   
End Function

Private Sub Auto_Close()
    Call CloseRemoteXLInstance
End Sub

2- SoundMe UDT function in a Standard Module:

Option Explicit

Public Function SoundMe _
    ( _
            Optional ByVal SoundFile As String, _
            Optional ByVal HowManyTimes As Integer = 1, _
            Optional ByVal IntervalDurationInSecs As Single = 1 _
    ) _
As String

   
    Call PlaySoundFromRemoteXLInstance(SoundFile, HowManyTimes, IntervalDurationInSecs)
             
    Select Case True
        Case IsNumeric(SoundFile)
            SoundFile = ""
        Case UCase(SoundFile) = "BEEP"
            SoundMe = "Playing"
        Case Len(SoundFile) = 0 Or Len(Dir(SoundFile)) = 0
            SoundFile = ""
        Case Else
            SoundMe = "Playing"
    End Select

End Function

Note:
The code is best if the SoundMe UDT function is applied to only one cell.

 

[Logit]

Jaafar Tribak

I'm running Excel 2007 and all I get in the formula cell is error #Value.

Will this not run in 2007 ?

 

[Jaafar Tribak]

Jaafar Tribak

I'm running Excel 2007 and all I get in the formula cell is error #Value.

Will this not run in 2007 ?

Is that error happening in the workbook example ?

I don't have excel 2007 to test but that error suggests a wrong data type is passed to the SoundMe function.

 

[Logit]

Is that error happening in the workbook example ?

Yes

Also, if I copy the code to my own workbook.

 

[Jaafar Tribak]

Is that error happening in the workbook example ?

Yes

Also, if I copy the code to my own workbook.

Do you see a seperate excel instance running in the task manager ( ALT+CTRL+DEL) ? and if so, does this second instance close when you close the workbook ?