how to loop reminder program in excel until esc key is pressed

L

lakmal

New Member
Joined
Jan 21, 2018
Messages
2
i have created an excel program to alert my works in office.Its alarm is ringing when it reaches the given time.but i need to stop this alarm when i pressed esc key.please help me with this.i'm not a programmer or related in that field.Here are my codes


Thank you
by lakmal




#If Win64 Then
Private Declare PtrSafe Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As LongPtr, ByVal dwFlags As Long) As Boolean
#Else
Private Declare Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Boolean
#End If
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
Function SoundMe() As String
'Updateby Extendoffice 20161223
Call PlaySound("c:\windows\media\Ring08.wav", _
0, SND_ASYNC Or SND_FILENAME)
SoundMe = ""
End Function
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Sort by date Sort by votes
Hi and welcome to the board.

You could use Application.Onkey to hook the ESC key and then pass the SND_PURGE to the PlaySound API in the OnKey macro but this method requires that the excel application be the active window when pressing the escape key.

Following is an alternative approach that is more involved but works regardless of the currently foreground window ... It uses a timer instead of a Do Loop which can inadvertently be broken very easily and instead of a global keyboard hook which is prone to crashing the entire application should an unhadled error occur.

Code in a Standard Module: and run the SoundMe macro
Code: 
Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Boolean
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As LongPtr) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId 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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Boolean
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId 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
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_PURGE = &H40
Private Const WS_SYSMENU = &H80000
Private Const GWL_STYLE = (-16)

Sub SoundMe()
    Call StartTimer
    Call PlaySound("c:\windows\media\Ring08.wav", 0, SND_ASYNC Or SND_FILENAME Or SND_LOOP)
End Sub

Sub StartTimer(Optional ByVal dummy As Boolean)
    KillTimer Application.hwnd, 0
    SetTimer Application.hwnd, 0, 100, AddressOf TimerProc
End Sub

Sub TimerProc(Optional ByVal dummy As Boolean)
[B][COLOR=#008000]    'Stop sound and timer if ESC key is pressed or if an unhandled error occurs.[/COLOR][/B]
     If GetAsyncKeyState(vbKeyEscape) Or IsBreakMode Then
        PlaySound vbNullString, 0, SND_PURGE
        KillTimer Application.hwnd, 0
     End If
End Sub

Function IsBreakMode() As Boolean
    Dim hCurPid As Long, hForegroundPid As Long
    Dim sbuffer As String, lRet As Long
     
    sbuffer = Space(256)
    lRet = GetClassName(GetForegroundWindow, sbuffer, 256)
    Call GetWindowThreadProcessId(Application.hwnd, hCurPid)
    Call GetWindowThreadProcessId(GetForegroundWindow, hForegroundPid)
    
    IsBreakMode = _
    (FindWindow("wndclass_desked_gsk", vbNullString) = _
    GetNextWindow(GetLastActivePopup(FindWindow("wndclass_desked_gsk", vbNullString)), 4)) Or _
    (GetWindowLong(GetForegroundWindow, GWL_STYLE) And WS_SYSMENU) = 0 And hForegroundPid = hCurPid And _
    Left(sbuffer, lRet) <> "Net UI Tool Window"
End Function
 
Upvote 0
I forgot to add code to stop the timer and sound when closing the workbook should they still be running at the time of closing and I also forgot to add the API declaration for the GetWindowLong function.

so skip the previous code and use this one :

Code: 
Option Explicit

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Boolean
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As LongPtr) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId 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
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
     [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Boolean
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_PURGE = &H40
Private Const WS_SYSMENU = &H80000
Private Const GWL_STYLE = (-16)

Sub SoundMe()
    Call StartTimer
    Call PlaySound("c:\windows\media\Ring08.wav", 0, SND_ASYNC Or SND_FILENAME Or SND_LOOP)
End Sub

Sub StartTimer(Optional ByVal dummy As Boolean)
    KillTimer Application.hwnd, 0
    SetTimer Application.hwnd, 0, 100, AddressOf TimerProc
End Sub

Sub TimerProc(Optional ByVal dummy As Boolean)
[B][COLOR=#008000]    'Stop sound and timer if ESC key is pressed or if an unhandled error occurs.[/COLOR][/B]
     If GetAsyncKeyState(vbKeyEscape) Or IsBreakMode Then
        PlaySound vbNullString, 0, SND_PURGE
        KillTimer Application.hwnd, 0
     End If
End Sub

Function IsBreakMode() As Boolean
    Dim hCurPid As Long, hForegroundPid As Long
    Dim sbuffer As String, lRet As Long
     
    sbuffer = Space(256)
    lRet = GetClassName(GetForegroundWindow, sbuffer, 256)
    Call GetWindowThreadProcessId(Application.hwnd, hCurPid)
    Call GetWindowThreadProcessId(GetForegroundWindow, hForegroundPid)
    
    IsBreakMode = _
    (FindWindow("wndclass_desked_gsk", vbNullString) = _
    GetNextWindow(GetLastActivePopup(FindWindow("wndclass_desked_gsk", vbNullString)), 4)) Or _
    (GetWindowLong(GetForegroundWindow, GWL_STYLE) And WS_SYSMENU) = 0 And hForegroundPid = hCurPid And _
    Left(sbuffer, lRet) <> "Net UI Tool Window"
End Function

Sub Auto_Close()
    PlaySound vbNullString, 0, SND_PURGE
    KillTimer Application.hwnd, 0
End Sub
 
Last edited:
Upvote 0
Mr Tribak thank you very much for serving your valuable time for me.
I have tried to use your code.but the problem is that while I'm pressing esc key alarm stop but it start again when i take hand.
In my excel sheet i have added real time clock update every second so the melody doesn't sound continuously.its okay for me ,but any how alarm doesn't stop it start again.can you give me a solution for this.

Thank you !
by lakmal
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Upgrade tp 64bit 'declare' need to b e
Replies
1
Views
646
GWteB
GWteB
S
  • Solved
getting columns to play sound when data is entered
Replies
2
Views
2K
skidda420
S
M
  • Question Question
Stop .wav file with button after started playing
Replies
2
Views
901
mewingpants
M
M
  • Question Question
Stop .wav file with button after started playing
Replies
5
Views
4K
John_w
J
davewatson86
  • Question Question
VBA/SAP help
Replies
0
Views
3K
davewatson86
davewatson86

Forum statistics

Threads
1,223,910
Messages
6,175,318
Members
452,634
Latest member
cpostell

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