Repeating Alarm and Message Box for Outlook 2007

Outlook Repetitive New Email Message Box
 and Sound Alarm


JAWChemist@gmail.com                                                                                07/31/2022
Disclaimer                                                                                              Ver. 20220731-01

INTRODUCTION
Microsoft Outlook can set advanced options for a newly received emails to be announced by playing a sound, displaying a visual desktop alert, briefly changing the mouse cursor and/or showing an envelope in the Outlook notification area.
 
PROBLEM
The announcements are transitory one-time events. They are not overly obvious and not repeated. If you are away from the computer, intently focused on other activities or focused on another screen, these can be missed. In order not to miss them, the arrival of new emails should be repeated to avoid missing the notifications while working or whenever returning to the computer. This can be an issue in situations where a fast and immediate response to an email is needed or expected.
 
SOLUTION
Coding was written to intercept a newly received email and present a more obvious message box, a continuous sound and would be repeated if no action is taken. The email alarm can be dismissed or repeated from the message box. If the message box is not acknowledged, it will time out and reset the timer to present the notifications to the user again. Other actions that will stop the alert from being repeated are: reading the email, moving it or deleting it. In these cases the alert is not repeated based on the assumption that any of these actions would indicate the email has been noticed and handled.
 
RESULTS
There are 2 sets of codes in this paper; “CODE MINIMAL” and “CODE”. “CODE MINIMAL” is “CODE” that has been stripped of features, a reduced the number of modules, incorporated code from the removed modules into other ones and streamlined code. The basic process for both is the same. “CODE” contains feature bloat accessible by editing the variables in the initialization code in Sub subMailMsgAlarmInitialize. The “CODE” also contains some logic to detect and process errors to prevent it from crashing as it was being developed. The errors seemed to be the result of conditions encountered while it was being debugged during the receipt of new emails and not a basic flaw in the code so the minimized code has some of this removed.
 
Both codes were resident at the same time and the reference to Sub subNewRcdEmailQue became ambiguous. The module containing the minimalized code was renamed as MailMsgAlarmBareCode and specifically identified in ThisOutlookSession Module Application.NewMailEx as MailMsgAlarmBareCode.subNewRcdEmailQue with the alternate code MailMsgAlarm.subNewRcdEmailQue being remarked out. The module qualification could be removed if only one set of code is used. Both process modules have worked effectively.
 
The discussion has a section on the results of investigating alternate approaches.
 
DISCUSSION
Overview
In the system tested, the currently used Outlook is 2007 in Windows 10. Emails are on a repetitive send/receive schedule to be downloaded from various internet accounts when Outlook is running.
 
When a new email is received through ThisOutlookSession Application_NewMailEx, its EntryID is added to a collection of new emails (c_NewRcdEmails). A timer (lNewRcdEmailsTimerID) is set to initiate the processing of the queued collection of new emails and control is returned to receive more new emails. This allows all newly received emails to quickly populate the collection for further processing. Newly received emails are not processed immediately as received because the time to process them causes other newly received emails to be missed (dropped) while waiting for a user or a message box timed out response.
 
The timer triggers the processing of the emails in either the MailMsgAlarm or in the minimalized code MailMsgAlarmBareCode module depending on which one is active in Sub Application_NewMailEx. Both use the subNewEmailMsgAlarmCollection procedure. A message box (MsgBox) will ask if an alarm is to be set for the email. If the message box times out or “Yes” is chosen, it is removed from the c_NewRcdEmails collection. The c_MsgAlarmEmails collection has an array of information. This array consists of the email’s sender name, subject, received time, entry id, timer ID assigned to it and a key that is a duplicate of the timer id. A timer is set that will repeat the alerts (message and sound) for the email and all of the email information and timer ID is added to the c_MsgAlarmEmails collection. The message box used is an undocumented part of the user32 library with the alias “MessageBoxTimeoutA”[1] [2] [3] [4] that can have a timeout set to close the message box. If no alarm is to be set, then that email is not added to the c_MsgAlarmEmails collection and its entry is removed from the c_NewRcdEmails collection. The c_NewRcdEmails collection is processed until it contains no more emails. This is process in “CODE MINIMALIZED”. For “CODE”, the email information will be put into the c_MsgAlarmEmails collection but with a negative dummy timer ID. Once the message box times out or “Yes” has been selected to alarm the email, the information is re-written into the c_MsgAlarmEmails collection with an actual timer ID or completely removed if ‘No” is chosen. This was to maintain the email information while the message box was exposed to the user and they could take action on the email before answering the message box. This now seem unnecessary.
 
Application_NewMailEx will continue to add new emails to the c_NewRcdEmails collection as they arrive. The set time for the timer between receiving the new emails and processing them is very short in the code listing (lNewRcdEmailTimerIntervalms = 1). A longer time has worked effectively.
 
Office 2007 with VBA 6.5 is used in Windows 10. Consequently, no coding for a 64 bit environment was done. A couple of references (4)[5] [6] are included as examples of what is needed in the declarations for the conditional compilation for 32 and 64 bit VBA code.
 
Features In “CODE”
The switches to turn the features on or off are in the Sub subMailMsgAlarmInitialize module. The features use various code modification methods for selection:
1.     Drop through variable setting 'Message Box section
Variables are listed and set to their run value. They are listed a second time and set to code testing values. When code testing is done, the second set of listings are edit to remove the apostrophe (“’”) used to comment out the code line. This is typified by the time for a message box to time out and for the time for a message box to repeat the alarm
lMsgBoxTimeoutms = 60000 'milliseconds 60000 = 1 minute
lTimerIntervalms = 600000 'milliseconds 600000 = 10 minutes
‘lMsgBoxTimeoutms = 10000 'milliseconds 10000 = 10 seconds
‘lTimerIntervalms = 30000 'milliseconds 30000 = 30 seconds
The 3rd and 4th lines are commented out when code testing is not being done. Typically, this is limited to a few lines of code. This has been moved to Sub subNewEmailMsgAlarmReminders in “CODE MINIMAL”.
This was also used in the 'DMR Deleted, Moved, or Read MsgBox Alert section that would give a confirmation alert to the user that the email had been move, deleted or read.
2.     Boolean switch to selection alternates 'Sound Files section
The sound files are initialized to default standard files in the “USERPROFILE” path and Windows 10 wav files. The variable bUseCustomFiles is set to True. This will override using the default files and will use custom files defined by their path and filename. To use the default files, the code line 'bUseCustomFiles = False has to have the comment apostrophe removed. This switch is not available in the minimized code and the path and filename has to be directly edited.
There are Boolean switches in the ‘Debugging and Logging section. These are used to debug.print information or log information to a file. The debug.print and logging code was removed after the code was robustly working but the switches were left in for future use. These are not in the minimized code.
3.     Audio output under the section 'Speaker-Headphone section
The audio output has four lines of code starting with “strAudioDevice = UCase” that will set the action to take:
a.     line 1 will make no change in the audio output
b.     line 2 will change it to headphones
c.     line 3 will change it to speakers and
d.     line 4 will ask what output device is wanted.
Each line could have a remark apostrophe. The LAST unmarked line is what action will be used. This section also contain the path and filename of batch files used to change the output audio device (speakers or headphones). Each of these batch files will call a required VBS file to change the output. The VBS code uses sendkeys to affect the change in audio output. These keys are sent to Windows, Settings, System, Sound (explorer ms-settings:sound ). A small time delay variable (lChangeAudioTestTimems) is defined to allow time for the sendkeys to be processed. The message box has a timeout so that the change in audio output device being used can be verified. The sound settings window will be displayed. A simple or more easily implemented way to change the audio device output device than sendkeys was not discovered. “There is no public API which allows you to change the default audio device, that is functionality that is considered to be under the users control. This has always been the case in Windows.”[7] [8] [9] [10]
 
Procedure List and Discussion (yellow highlighted are in both sets of code)
(Declaration)
Sub subMailMsgAlarmInitialize(strNewRcdEmailEntryID)
Most control and user variables are defined in this procedure. None are made available through any input and must be altered in the code. The variables are prefaced with a type indicator like b for Boolean and str for string. Many of these deal with features and were removed in the minimalized code. Those necessary were move into the subNewEmailMsgAlarmReminders module and so this module is not used in the minimalized code.
Sub subCleanUp(Optional DummyMacroNoShow As Integer)
This used code destroyed objects. The code was move to the subNewEmailMsgAlarmReminders in the minimized code and so this module is not used in the minimalized code.
Sub subNewRcdEmailQue(strNewRcdEmailEntryID)
This intercepts new emails from Application_NewMailEx, puts their EntryID in a collection queue and sets a timer to process the collection (subNewEmailMsgAlarmCollection). As new emails arrive, they can be added to the queue or if it is empty, a new one is started.
Sub subNewEmailMsgAlarmCollection(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
This is the procedure activated by the timer in subNewRcdEmailQue and processes the entries in the collection. For each email, it calls the subNewEmailMsgAlarmReminders module until all the emails in the collection are alarmed or not alarmed.
Sub subNewEmailMsgAlarmReminders(ByVal oAlertEmail As Outlook.MailItem)
This module gets input from the user on whether to set an alarm for the email being processed or not. The email information is to the c_MsgAlarmEmails collection with a dummy timer ID. If it is to alarmed, a real timer ID replaces the temporary timer ID and set to re-alert the user. The timer goes to subTimerHandler. If not alarmed, the entry for that email in the collection is removed. The dummy timer ID was use so store an emails information while the message box was presented to the user. This was done as a preventative measure should the user delete, move or read the email while the message box was open so that the email information could be presented to the user without having to find where it was located or lost if permanently deleted. The minimal code was altered not to use a dummy timer ID and any code associated with generating the dummy timer ID (lpSystemTime, SYSTEMTIME, lTimerIdDummy) was removed.
Sub subTimerHandler(ByVal lhWnd As Long, ByVal lMsg As Long, ByVal lTimerID As Long, ByVal lTime As Long)
The individual timer for each email calls this module. It asks the user to re-alarm the email or to dismiss the alarm. If the alarm is dismissed or it if the email has been handled, the alarm is killed and the email is removed from the c_MsgAlarmEmails collection.
Sub subEmailDMR_MsgBox(iEmailStatus As Integer, lTimerID As Long)
After funcEmailNotDMRItemNumber determines the status of the email and that it has been handled, it presents a text of how it was handled in a message box to the user. The timer for it is killed and it is removed from the c_MsgAlarmEmails collection. The minimized code was altered. The minimized code simple checks if the email was in the inbox and not read. If this is not the case, it was assumed the email was handled and no message is given to the user about it being handled or how it was handled. The timer for it is killed and it is removed from the c_MsgAlarmEmails collection. However, the code for killing the timer and removing the email from the c_MsgAlarmEmails collection was moved to the subTimerHandler and this module was then not needed in the minimalized code.
Function funcEmailNotDMRItemNumber(ByVal strEmailEntryID As String) As Integer
This determines if the email was deleted, moved or read (DMR). If the bDMRAlert = True , then the “CODE” will present a message box that will indicate what action was taken. If bDMRAlert = False, no message box is shown. For “CODE MINIMAL” this will simple assign any action taken as it being read and by default no DMR alert message box is shown (subEmailDMR_MsgBox is not called).
Function funcShowSetReminder(ByVal oNewEmail As Outlook.MailItem, lTimerIntervalms As Long, lMsgBoxTimeoutms As Long) As Integer
This sets up the text information to show in the message box that alerts the user that an alarm was set. For “CODE” it will adjust the message time and units based on the length of time the message box is active (lMsgBoxTimeoutms) and the time till the alarm will be repeated (lTimerIntervalms). For “CODE MINIMAL”, the message box time out is set to 1 minute (60000 milliseconds) and the alarm is repeated is 10 minutes (600000 milliseconds). The message box text is structured for these specific times and units.
Sub subDebugAndLogCodeExample(Optional Void As Integer)
This contained examples of debug coding using debug.print and file logging of information. The actual code in the modules was used for developing and debugging the procedure. All the actual code was removed. This example code is not included in the minimized code.
Sub subUseAudioDevice(strAudioDevice As String, strAudioDeviceTestSoundPathFname As String)
This was used to change the audio output device from the speakers to the headphones. It is a kluge using batch and VBS files. It was used to solve the issue of a particular work environment like an open office or home area where speaker alarms would be annoying for others and headphone preferable or the alternate case where being away from the computer and speakers would be needed. It would be better handled by either plugging or unplugging the headphones as needed since with them unplugged the sound would default to the speakers. The alternate would be to use the Windows sound settings and change the output as needed. This could be done manually or the batch + VBS code for each output device could be initiated by a shortcut. The sounds are played using the library function in winmm.dll with the alias “sndPlaySoundA”. They are played asynchronously and in a loop using &H9. The sound is stopped by using vbNullString.
 
Issues
The code uses undocumented API code "MessageBoxTimeoutA” in the user32 library. As with any undocumented code, it may not be available in the future but has been available since Windows 7.
 
It was difficult to trap a specific error if an email was moved and the EntryID became invalid. A general On Error trap was used. If the email was moved while the message box was shown in subNewEmailMsgAlarmReminders, the EntryID became oAlertEmail.EntryID = <The item has been moved or deleted.>. A method to specifically detect this content was not found and the run-tine error shown in the debug message box did not seem to be consistent.

MsgBox 1 Run-time Error When Email is Moved
 
Alternate Approach To MsgBox Timeout
The SlipStick forum was joined and the fact that WshShell.Popup[11] worked with other office applications but not with Outlook was discussed. Diane Poremsky quickly responded and indicated that “Outlook via doesn’t have a timer function” and that “Vboffice.net has a timer sample.”[12] I was unable completely understand or make use of the information. This is presented as others may be able to make use of it.
 
Vboffice.net seemed to be a site that sells add-ins. There was a timer example[13] but it was unclear how to incorporate the timer into making a MsgBox timeout.
 
Additional confusion occurred because in Outlook a timer was started, stopped after 5 seconds and displayed the elapsed time in a MsgBox. This seemed much like the timer example in Vboffice.net.
 
 “CODE MINIMAL”
ThisOutlookSession
Private Sub Application_NewMailEx(ByVal strNewlyRcdEmailEntryID As String)
MailMsgAlarmBareCode.subNewRcdEmailQue strNewlyRcdEmailEntryID
End Sub
 
Modules-MailMsgAlarm
 (Declaration)
Option Explicit
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 sndPlaySound32 _
Lib "winmm.dll" _
Alias "sndPlaySoundA" ( _
ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Private Declare Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) _
As Long
 
Dim olInboxFolder As Outlook.Folder
Dim c_NewRcdEmails As New Collection 'Collection of emails as they arrive EntryId, Key(EntryID)
Dim c_MsgAlarmEmails As New Collection
'c_MsgAlarmEmails Format: collection.add
'c_MsgAlarmEmails get items: collection.item(1)(0) give strSenderName
'c_MsgAlarmEmails get items: collection.item(1)(1) give strSubject
'c_MsgAlarmEmails get items: collection.item(1)(2) give strReceivedTime
'c_MsgAlarmEmails get items: collection.item(1)(3) give strEntryID
'c_MsgAlarmEmails get items: collection.item(1)(4) give lTimerId - should be same as Key
'c_MsgAlarmEmails get items: Key(CStr(lTimerId))
'Could add hWnd
'Https://www.tek-tips.com/viewthread.cfm?qid=1328415
 
'Time intervals and Folders
Dim lNewRcdEmailsTimerID As Long 'Timer to process the c_NewRcdEmails collection.
Dim lMsgBoxTimeoutms As Long
Dim lTimerIntervalms As Long
Dim strResetTimerSoundPathFname As String
 
Sub subNewRcdEmailQue(strNewRcdEmailEntryID)
Dim lNewRcdEmailTimerIntervalms As Long
lNewRcdEmailTimerIntervalms = 1 '10000 'A longer time allow incoming emails to que up before processing.
c_NewRcdEmails.Add strNewRcdEmailEntryID, strNewRcdEmailEntryID
'lNewRcdEmailsTimerID becomes 0 on entry to this sub, is Empty if not initialized
'Can initilized it in ThisOutlookSession, Private Sub Application_Startup(), if desired
If lNewRcdEmailsTimerID = 0 Or IsEmpty(lNewRcdEmailsTimerID) Then
lNewRcdEmailsTimerID = SetTimer(0&, 0&, lNewRcdEmailTimerIntervalms, AddressOf subNewEmailMsgAlarmCollection)
End If
End Sub
 
Sub subNewEmailMsgAlarmCollection(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
'This runs through the new emails in the c_NewRcdEmails collection que and
'puts them in the MsgAlarm collection if an alert is set
'Alaming them as the emails arrived in subNewRcdEmailQue would drop emails
'due to too long a response time from setting the alarms
Dim oAlertEmail As Object
Dim I As Integer
KillTimer 0&, lNewRcdEmailsTimerID 'Timer used to process Newly Received Emails in Application_NewMailEx
I = 0
Do Until c_NewRcdEmails.Count = 0
'Item 1 of the collection is handled and then removed
'the item being worked on should always be 1 unless there is a unexpected error
I = I + 1
Set oAlertEmail = Session.GetItemFromID(c_NewRcdEmails.Item(I))
c_NewRcdEmails.Remove (I)
I = I - 1
subNewEmailMsgAlarmReminders oAlertEmail
Loop
lNewRcdEmailsTimerID = 0
Set c_NewRcdEmails = Nothing
Set oAlertEmail = Nothing
End Sub
 
Sub subNewEmailMsgAlarmReminders(ByVal oAlertEmail As Outlook.MailItem)
Dim olNS As Outlook.NameSpace
Dim olApp As Outlook.Application
 
Dim strNewEmailSoundPathFname As String
Dim strSetTimerErrorSoundPathFname As String
Dim lTimerID As Long 'Passed as a parameter name in other procedures
Dim strMsgBoxMessage As String 'Name is used locally in other prodcedures
Dim lBoxStyle As Long 'Name is used locally in other prodcedures
Dim iMsgBoxResponse As Integer 'Name is used locally in another prodcedure
Dim iEmailStatus As Integer 'Passed as a parameter name in another procedure
Dim bUnread As Boolean
 
'Initialize
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInboxFolder = olNS.GetDefaultFolder(olFolderInbox)
'NOTE the Timer automatically repeats if not killed or reset
'Timer Intervals need to be longer than MsgBox TimeOut otherwise unattended message boxes would build up
lMsgBoxTimeoutms = 60000 'milliseconds 60000 = 1 minute
lTimerIntervalms = 600000 'milliseconds 600000 = 10 minutes
'Remove "'" next 2 lines to speed up testing
‘lMsgBoxTimeoutms = 10000 'milliseconds 10000 = 10 seconds
‘lTimerIntervalms = 30000 'milliseconds 30000 = 30 seconds
If lTimerIntervalms < lMsgBoxTimeoutms * 1.1 Then lTimerIntervalms = lMsgBoxTimeoutms * 1.1
strNewEmailSoundPathFname = "C:\Windows\Media\Windows Notify Email.wav"
strSetTimerErrorSoundPathFname = "C:\Windows\Media\Windows Error.wav"
strResetTimerSoundPathFname = "C:\Windows\Media\ringout.wav"
 
'Tell user of new email
sndPlaySound32 strResetTimerSoundPathFname, &H9 'Sound New Mail Arriving
iMsgBoxResponse = funcShowSetReminder(oAlertEmail, lTimerIntervalms, lMsgBoxTimeoutms) 'Reminder MsgBox
sndPlaySound32 vbNullString, &H9 'Stop sound after MsgBox
 
'While MsgBox up user could Delete (or Delete permanently), Move or Read email (DMR)
'Check if entryID is still in Inbox
iEmailStatus = -1
On Error GoTo MovedOrDeleted
iEmailStatus = funcEmailNotDMRItemNumber(oAlertEmail.EntryID)
MovedOrDeleted:
On Error GoTo -1 '0
If iEmailStatus <> -1 Then
'Check if email is still present and unread THIS WORKS TO FIND EMAIL IF MOVED!!!
Set oAlertEmail = CreateObject("Outlook.Application").GetNamespace("MAPI").GetItemFromID(oAlertEmail.EntryID)
CreateObject("Outlook.Application").GetNamespace("MAPI").Logon "", "", False, True
bUnread = CreateObject("Outlook.Application").GetNamespace("MAPI").GetItemFromID(oAlertEmail.EntryID).UnRead
If bUnread = False Then iEmailStatus = -1
End If
'iEmailStatus is -1 if deleted, moved or read; or a number that is the position on the list of emails in the items.
 
'New email, Set or ignore making timer for it
Select Case iMsgBoxResponse
Case 6, 32000 'Set timer if unread and in Inbox: Yes = 6 , timeout = 32000
If iEmailStatus = -1 Then
sndPlaySound32 strSetTimerErrorSoundPathFname, &H9
strMsgBoxMessage = "Timer was not set. Email deleted, moved or read and assumed handled."
'This MsgBox does not timeout so that a critical email is not inadvertently moved and forgotten
MsgBox strMsgBoxMessage, lBoxStyle, "Email Message!"
'lDummyReturn = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lTimeoutMillisec)
sndPlaySound32 vbNullString, &H9
Else
lBoxStyle = vbOKOnly + vbInformation + vbDefaultButton1 + vbSystemModal + vbMsgBoxSetForeground
'If subTimerHandler is not valid, Outlook will crash
'Hand the function pointer for subTimerHandle to the API, it calls you back (callback)
lTimerID = SetTimer(0&, 0&, lTimerIntervalms, AddressOf subTimerHandler)
If lTimerID > 0 Then
c_MsgAlarmEmails.Add Array(oAlertEmail.SenderName, oAlertEmail.Subject, oAlertEmail.ReceivedTime, oAlertEmail.EntryID, lTimerID), CStr(lTimerID)
Else
‘Setting timer failed
sndPlaySound32 strSetTimerErrorSoundPathFname, &H9 'funcPlaySound (strSetTimerErrorSoundPathFname)
strMsgBoxMessage = "Timer could not be created and set."
'This MsgBox does not timeout so that a critical email is not inadvertently forgotten
MsgBox strMsgBoxMessage, lBoxStyle, "Email Message!"
'lDummyReturn = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lTimeoutMillisec)
sndPlaySound32 vbNullString, &H9
End If
End If
Case 7 'No = 7
'No timer to kill because no timer set
End Select
End Sub
 
Sub subTimerHandler(ByVal lhWnd As Long, ByVal lMsg As Long, ByVal lTimerID As Long, ByVal lTime As Long)
Dim iEmailItemStatus As Integer
Dim strEmailEntryID As String
Dim iMsgBoxResponse As Integer 'Name is in another procedure
Dim iDummy As Integer
 
strEmailEntryID = c_MsgAlarmEmails.Item(CStr(lTimerID))(3)
iEmailItemStatus = funcEmailNotDMRItemNumber(strEmailEntryID)
If iEmailItemStatus > 0 Then
'Email not move, deleted or read (DMR), so it is in Inbox and unread
'Show MsgBox asking to reset alarm
'Stop sound after MsgBox
sndPlaySound32 strResetTimerSoundPathFname, &H9
Dim oAlertedEmail As Outlook.MailItem
Set oAlertedEmail = olInboxFolder.Items.Item(iEmailItemStatus)
iMsgBoxResponse = funcShowSetReminder(oAlertedEmail, lTimerIntervalms, lMsgBoxTimeoutms)
sndPlaySound32 vbNullString, &H9
'Recheck if there since user could have DMR'ed it when msgbox was open
iEmailItemStatus = funcEmailNotDMRItemNumber(strEmailEntryID)
'Item in Inbox
'Handle alarm and collection
Select Case iMsgBoxResponse
Case 6, 32000 'Reset alarm by user selection or timeout of msgbox
'timer repeats withou reseting.
Case 7 'Alert is not Rerun
KillTimer 0&, lTimerID
c_MsgAlarmEmails.Remove CStr(lTimerID)
Case Else
MsgBox "Unknown Error. There should be no other type of response from MsgBox that ask about setting up Alert.", vbOKOnly
End Select
Else
'Email is not in Inbox, remove it from alarmed emails
KillTimer 0&, lTimerID
c_MsgAlarmEmails.Remove CStr(lTimerID)
End If
End Sub
 
Function funcEmailNotDMRItemNumber(ByVal strEmailEntryID As String) As Integer
'DMR Delete, Moved, Read
Dim olMailItem As Object
Dim I As Integer
'Return code
'>0 item number in Inbox
'0 there but Read or Moved or Deleted (DMR)
 
'Set is as DMR
funcEmailNotDMRItemNumber = 0
'Check if Email there and is Unread
'If InBox sorted by date most recent to oldest I will have the Item number if found
'numbering from bottom (1) to top (## item is status bar)
For I = olInboxFolder.Items.Count To 1 Step -1
If olInboxFolder.Items.Item(I).EntryID = strEmailEntryID Then Exit For 'I has item's number on list so is there
Next I
If I > 0 Then
'Item is in Inbox
funcEmailNotDMRItemNumber = I 'There and assumed unread
If olInboxFolder.Items.Item(I).UnRead = False Then funcEmailNotDMRItemNumber = 0 'There but is read set = 0
End If
Set olMailItem = Nothing
End Function
 
Function funcShowSetReminder(ByVal oNewEmail As Outlook.MailItem, lTimerIntervalms As Long, lMsgBoxTimeoutms As Long) As Integer
'Show Message Box to set reminder timer
Dim strMsgBoxMessage As String
Dim lBoxStyle As Long 'Name is used in other prodcedures
Dim iMsgBoxButton As Integer
Dim iDefaultButton As Integer
Dim intMsgBoxTimeoutResponse As Integer
 
'MsgBox string for Timer
Dim lMsgBoxTimerIntervalSec As Long
Dim strMsgBoxTimerInterval As String
Dim strMsgBoxTimerUnits As String
Dim strMsgBoxTimerTimeUnits As String
 
'MsgBox string for MsgBox Timeout
Dim lMsgBoxTimeOutSec As Long
Dim strMsgBoxTimeOut As String
Dim strMsgBoxTimeOutUnits As String
Dim strMsgBoxTimeOutTimeUnits As String
 
'MsgBox Style enumerations 5 groups: button, icon, default button, modal type, other
'vbYesNo = 4
'vbQuestion = 32
'vbDefaultButton1 = 0 (Yes if YesNo)
'vbSystemModal = 4096 Require response before going back to application
'vbApplicationModal = 0 Alternate modal if System Modal too intrusive
'vbMsgBoxSetForeground = 65536 'put msgbox in front of all windows
lBoxStyle = vbYesNo + vbQuestion + vbDefaultButton1 + vbSystemModal + vbMsgBoxSetForeground
lMsgBoxTimerIntervalSec = lTimerIntervalms / 1000
lMsgBoxTimeOutSec = lMsgBoxTimeoutms / 1000
strMsgBoxTimerInterval = CStr(Round(lMsgBoxTimerIntervalSec / 60, 0))
strMsgBoxTimerUnits = " minutes"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
strMsgBoxTimeOut = CStr(Round(lMsgBoxTimeOutSec / 60, 0))
strMsgBoxTimeOutUnits = " minutes"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
strMsgBoxMessage = "Repeat email reminder in " & strMsgBoxTimerTimeUnits & "?" & vbLf _
& "From: " & oNewEmail.SenderName & vbLf _
& "Subject: " & oNewEmail.Subject & vbLf _
& "(Default Yes and closes in " & strMsgBoxTimeOutTimeUnits & ")" & vbLf _
& " "
funcShowSetReminder = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lMsgBoxTimeoutms)
'Return code is Yes = 6, No = 7, timeout = 32000
'While MsgBox up user could Delete, Move or Read email and
'it needs to be checked before putting it in collection
End Function
 
“CODE”
Microsoft Office Outlook Objects
ThisOutlookSession
Private Sub Application_NewMailEx(ByVal strNewlyRcdEmailEntryID As String)
MailMsgAlarm.subNewRcdEmailQue strNewlyRcdEmailEntryID
End Sub
 
Modules-MailMsgAlarm
(Declaration)
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
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 sndPlaySound32 _
Lib "winmm.dll" _
Alias "sndPlaySoundA" ( _
ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
Private Type SYSTEMTIME
Year As Integer
Month As Integer
DayOfWeek As Integer
Day As Integer
Hour As Integer
Minute As Integer
Second As Integer
Milliseconds As Integer
End Type
Private Declare Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) _
As Long
 
Dim olNS As Outlook.NameSpace
Dim olApp As Outlook.Application
Dim olInboxFolder As Outlook.Folder
Dim c_NewRcdEmails As New Collection 'Collection of emails as they arrive EntryId, Key(EntryID)
Dim c_MsgAlarmEmails As New Collection
'c_MsgAlarmEmails Format: collection.add
'c_MsgAlarmEmails get items: collection.item(1)(0) give strSenderName
'c_MsgAlarmEmails get items: collection.item(1)(1) give strSubject
'c_MsgAlarmEmails get items: collection.item(1)(2) give strReceivedTime
'c_MsgAlarmEmails get items: collection.item(1)(3) give strEntryID
'c_MsgAlarmEmails get items: collection.item(1)(4) give lTimerId - should be same as Key
'c_MsgAlarmEmails get items: Key(CStr(lTimerId))
'Could add hWnd
'Https://www.tek-tips.com/viewthread.cfm?qid=1328415
 
'Time intervals and Folders
Dim lNewRcdEmailsTimerID As Long 'Timer to process the c_NewRcdEmails collection.
Dim lMsgBoxTimeoutms As Long
Dim lTimerIntervalms As Long
Dim strNewEmailSoundPathFname As String
Dim strSetTimerErrorSoundPathFname As String
Dim strResetTimerSoundPathFname As String
 
'DMR Delete, Move, or Read MsgBox
Dim bDMRAlert As Boolean
 
'Speaker-Headphone
Dim strAudioDevice As String
Dim strAudioDeviceTestSoundPathFname As String
Dim lMsgBoxSpeakerHeadphonesTimeoutms As Long
Dim strAudioDeviceHeadphonesBatFile As String
Dim strAudioDeviceSpeakersBatFile As String
Dim lChangeAudioTestTimems As Long
 
'Debug and Log
Dim bMailMsgAlarmDebugPrint As Boolean
Dim bMailMsgAlarmLog As Boolean
Dim strFolderFileLog As String
 
Sub subMailMsgAlarmInitialize(strNewRcdEmailEntryID)
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInboxFolder = olNS.GetDefaultFolder(olFolderInbox)
 
'Message Box
'NOTE the Timer automatically repeats if not killed or reset
'Timer Intervals need to be longer than MsgBox TimeOut otherwise unattended message boxes would build up
'Choose your own times
lMsgBoxTimeoutms = 60000 'milliseconds 60000 = 1 minute
lTimerIntervalms = 600000 'milliseconds 600000 = 10 minutes
'Remove "'" next 2 lines to speed up testing
‘lMsgBoxTimeoutms = 10000 'milliseconds 10000 = 10 seconds used for testing
‘lTimerIntervalms = 30000 'milliseconds 30000 = 30 seconds used for testing
'Check time intervals, if timer interval repeat is faster than MsgBox Close it will build up MsgBoxes
If lMsgBoxTimeoutms >= lTimerIntervalms * 0.9 Then
lMsgBoxTimeoutms = 10000
lTimerIntervalms = 30000
Dim lDummyReturn As Long, strMsgBoxMessage As String, lBoxStyle As Long, lTimeoutMillisec As Long
strMsgBoxMessage = "The timeout for the message box to stay open is longer than" & vbLf _
& "the time between repeating the alarm for the message." & vbLf _
& "The message box timeout has been set to 10 seconds and" & vbLf _
& "repeating the alarm has been set to 30 seconds." & vbLf _
& "Set the times in the code procedure 'subMailMsgAlarmInitialize'."
lBoxStyle = 48 'vbOKOnly 0, vbExclamation 48
lTimeoutMillisec = 30000
lDummyReturn = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lTimeoutMillisec)
End If
 
'Sound Files
Dim bUseCustomFiles As Boolean
bUseCustomFiles = True 'To line below for sound files to use: remove "'" = default Windows files, add "'" = custom files
'bUseCustomFiles = False
Dim strUserPath As String
strUserPath = Environ("USERPROFILE")
'Edit folder and file names to your choices
strNewEmailSoundPathFname = "C:\Windows\Media\Windows Notify Email.wav"
strSetTimerErrorSoundPathFname = "C:\Windows\Media\Windows Error.wav"
strResetTimerSoundPathFname = "C:\Windows\Media\ringout.wav"
If bUseCustomFiles = True Then
strNewEmailSoundPathFname = "C:\Windows\Media\NewEmailArrived.wav" 'Bomb; 7 seconds
strSetTimerErrorSoundPathFname = "C:\Windows\Media\NewEmailTimerError.wav" 'Siren, 14 seconds
strResetTimerSoundPathFname = "C:\Windows\Media\NewEmailTimerAlarm.wav" 'Mechanical Alarm Clock Alarm, 14 seconds
End If
 
'Speaker-Headphone
'Remove "'" on which of the 4 choices below is wanted
strAudioDevice = UCase("No Change")
'strAudioDevice = UCase("Headphones")
'strAudioDevice = UCase("Speakers")
'strAudioDevice = UCase("Ask")
strAudioDeviceTestSoundPathFname = "C:\Windows\Media\notify.wav"
If bUseCustomFiles = True Then strAudioDeviceTestSoundPathFname = "C:\Windows\Media\notify.wav"
lMsgBoxSpeakerHeadphonesTimeoutms = 30000
strAudioDeviceHeadphonesBatFile = strUserPath & "SetSoundToHeadphone.bat"
strAudioDeviceSpeakersBatFile = strUserPath & "SetSoundToSpeaker.bat"
If bUseCustomFiles = True Then
strAudioDeviceHeadphonesBatFile = "D:\Users\JAWjr\Documents\Home\HouseItems\Computer\Devices\Sound\SetSoundToHeadphone.bat"
strAudioDeviceSpeakersBatFile = "D:\Users\JAWjr\Documents\Home\HouseItems\Computer\Devices\Sound\SetSoundToSpeaker.bat"
End If
lChangeAudioTestTimems = 5000
 
'DMR Deleted. Moved, or Read MsgBox Alert
bDMRAlert = True 'Add "'" below to turn on DMR Alert
'bDMRAlert = False
 
'Debug and Logging - see subDebugLogCodeExample, Debug.Print and logging to file removed from code
bMailMsgAlarmDebugPrint = False 'Remove "'" below to turn on Debug.Print
'bMailMsgAlarmDebugPrint = True
'Make 1 log file per day, filename has YYYYMMDD appended, appends information, notes restarting Outlook.
bMailMsgAlarmLog = False 'Remove "'" below to turn on logging
'bMailMsgAlarmLog = True
Dim strFolderAndPartName As String
strFolderAndPartName = strUserPath & "\Documents\NewEmailAlertAndAlarm"
If bUseCustomFiles = True Then strFolderAndPartName = "D:\Users\JAWjr\Documents\Home\HouseItems\Computer\MSOfficeFiles\Outlook\NewEmailAlertAndAlarm\Log\NewEmailAlertAndAlarm"
If bMailMsgAlarmLog = True Then
Dim strMonth As String
Dim strDay As String
strMonth = CStr(Month(Now()))
strDay = CStr(Day(Now()))
If Len(strMonth) < 2 Then strMonth = "0" & strMonth
If Len(strDay) < 2 Then strDay = "0" & strDay
strFolderFileLog = strFolderAndPartName & Year(Now()) & strMonth & strDay & ".Log"
Dim strLogExist As String
Dim iFileNum As Integer
iFileNum = FreeFile(0)
If "" = Dir(strFolderFileLog) Then 'If file does not exist Dir returns = "" otherwise filename
Open strFolderFileLog For Append As #iFileNum
Print #iFileNum, Now(), "New Mail Alarm Logging"
Else
Open strFolderFileLog For Append As #iFileNum
Print #iFileNum, Now(), "Outlook Restarted"
End If
Close #1
End If
End Sub
 
Sub subCleanUp(Optional DummyMacroNoShow As Integer)
Set olApp = Nothing
Set olNS = Nothing
'olInboxFolder is used by the alternate enter to this module (SubTimerHandler) so did not Set it to nothing
'Set olInboxFolder = Nothing
End Sub
 
Sub subNewRcdEmailQue(strNewRcdEmailEntryID)
Dim lNewRcdEmailTimerIntervalms As Long
lNewRcdEmailTimerIntervalms = 1 '10000 'A longer time allow incoming emails to que up before processing.
c_NewRcdEmails.Add strNewRcdEmailEntryID, strNewRcdEmailEntryID
'lNewRcdEmailsTimerID becomes 0 on entry to this sub, is Empty if not initialized
'Can initilized it in ThisOutlookSession, Private Sub Application_Startup(), if desired
If lNewRcdEmailsTimerID = 0 Or IsEmpty(lNewRcdEmailsTimerID) Then
lNewRcdEmailsTimerID = SetTimer(0&, 0&, lNewRcdEmailTimerIntervalms, AddressOf subNewEmailMsgAlarmCollection)
End If
End Sub
 
Sub subNewEmailMsgAlarmCollection(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
'This runs through the new emails in the c_NewRcdEmails collection que and
'puts them in the MsgAlarm collection if an alert is set
'Alaming them as the emails arrived in subNewRcdEmailQue would drop emails due to too long a response time from setting the alarms
Dim oAlertEmail As Object
Dim I As Integer
KillTimer 0&, lNewRcdEmailsTimerID 'Timer used to process Newly Received Emails in Application_NewMailEx
I = 0
Do Until c_NewRcdEmails.Count = 0
'Item 1 of the collection is handled and then removed
'the item being worked on should always be 1 unless there is a unexpected error
'the collection was checked to make sure the timer ID exists to prevent the code from crashing
'but this seems unnecessary and error checks have been 'x???? out
I = I + 1
'xErr.Clear
'xOn Error GoTo EmailMoved
Set oAlertEmail = Session.GetItemFromID(c_NewRcdEmails.Item(I))
'xOn Error GoTo -1 '0
c_NewRcdEmails.Remove (I)
I = I - 1
subNewEmailMsgAlarmReminders oAlertEmail
'xEmailMoved:
'xOn Error GoTo -1 '0
Loop
subCleanUp
lNewRcdEmailsTimerID = 0
Set c_NewRcdEmails = Nothing
Set oAlertEmail = Nothing
End Sub
 
Sub subNewEmailMsgAlarmReminders(ByVal oAlertEmail As Outlook.MailItem)
Dim iMsgBoxResponse As Integer 'Name is used locally in another prodcedure
Dim bUnread As Boolean
Dim timeSystem As SYSTEMTIME
Dim lTimerIdDummy As Long
Dim lBoxStyle As Long 'Name is used locally in other prodcedures
Dim iEmailStatus As Integer 'Passed as a parameter name in another procedure
Dim lTimerID As Long 'Passed as a parameter name in other procedures
Dim strMsgBoxMessage As String 'Name is used locally in other prodcedures
 
subMailMsgAlarmInitialize oAlertEmail.EntryID
subUseAudioDevice strAudioDevice, strAudioDeviceTestSoundPathFname
 
'Calculated dummy timer ID from system timer use 9 digits to fit long and make negative
GetSystemTime timeSystem
With timeSystem
lTimerIdDummy = -1 * (.Day - Int(.Day / 10) * 10 & .Hour & .Minute & .Second & .Milliseconds / 10)
End With
'Add NewEmail temporarily to the c_MsgAlarmEmails collection using dummy lTimerIdDummy
c_MsgAlarmEmails.Add Array(oAlertEmail.SenderName, oAlertEmail.Subject, oAlertEmail.ReceivedTime, oAlertEmail.EntryID, CStr(lTimerIdDummy)), CStr(lTimerIdDummy)
'If user alarms it, remove temporary lTimerIDummy and rewrite with real lTimerID
 
'Tell user of new email
sndPlaySound32 strResetTimerSoundPathFname, &H9 'Sound New Mail Arriving
iMsgBoxResponse = funcShowSetReminder(oAlertEmail, lTimerIntervalms, lMsgBoxTimeoutms) 'Reminder MsgBox
sndPlaySound32 vbNullString, &H9 'Stop sound after MsgBox
 
'While MsgBox up user could Delete (or Delete permanently), Move or Read email (DMR)
'Check if entryID is still in Inbox
iEmailStatus = -1
On Error GoTo MovedOrDeleted
iEmailStatus = funcEmailNotDMRItemNumber(oAlertEmail.EntryID)
'Return code
'>0 item number in Inbox
'0 there but Read
'-1 in store but not in Inbox so Moved
'-2 permanently deleted
MovedOrDeleted:
On Error GoTo -1 '0
If iEmailStatus <> -1 Then
'Check if email is still present and unread THIS WORKS TO FIND EMAIL IF MOVED!!!
Set oAlertEmail = CreateObject("Outlook.Application").GetNamespace("MAPI").GetItemFromID(oAlertEmail.EntryID)
CreateObject("Outlook.Application").GetNamespace("MAPI").Logon "", "", False, True
bUnread = CreateObject("Outlook.Application").GetNamespace("MAPI").GetItemFromID(oAlertEmail.EntryID).UnRead
If bUnread = False Then iEmailStatus = -1
End If
'iEmailStatus is -1 if deleted or moved or a number that is the position on the list of emails in the items.
 
'New email, Set or ignore making timer for it
Select Case iMsgBoxResponse
Case 6, 32000 'Set timer if unread and in Inbox: Yes = 6 , timeout = 32000
If iEmailStatus = -1 Then
'Remove dummy timer entry
c_MsgAlarmEmails.Remove CStr(lTimerIdDummy)
'Alert user email was deleted, moved or read
'This MsgBox does not timeout so that a critical email is not inadvertently moved and forgotten
sndPlaySound32 strSetTimerErrorSoundPathFname, &H9
strMsgBoxMessage = "Timer was not set. Email deleted, moved or read and assumed handled."
'Timed out message box format
'lDummyReturn = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lTimeoutMillisec)
MsgBox strMsgBoxMessage, lBoxStyle, "Email Message!"
sndPlaySound32 vbNullString, &H9
Else
'If subTimerHandler is not valid, Outlook will crash
'Hand the function pointer for subTimerHandle to the API, it calls you back (callback)
lTimerID = SetTimer(0&, 0&, lTimerIntervalms, AddressOf subTimerHandler)
If lTimerID > 0 Then
'Remove dummy timer entry and replace with Alert using real TimerID
c_MsgAlarmEmails.Remove CStr(lTimerIdDummy)
c_MsgAlarmEmails.Add Array(oAlertEmail.SenderName, oAlertEmail.Subject, oAlertEmail.ReceivedTime, oAlertEmail.EntryID, lTimerID), CStr(lTimerID)
Else
'Setting timer failed
'Remove dummy timer entry
c_MsgAlarmEmails.Remove CStr(lTimerIdDummy)
lBoxStyle = vbOKOnly + vbInformation + vbDefaultButton1 + vbSystemModal + vbMsgBoxSetForeground
sndPlaySound32 strSetTimerErrorSoundPathFname, &H9 'funcPlaySound (strSetTimerErrorSoundPathFname)
strMsgBoxMessage = "Timer could not be created and set."
'This MsgBox does not timeout so that a critical email is not inadvertently forgotten
MsgBox strMsgBoxMessage, lBoxStyle, "Email Message!"
'lDummyReturn = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lTimeoutMillisec)
sndPlaySound32 vbNullString, &H9
End If
End If
Case 7 'No = 7
'Remove dummy timer entry
c_MsgAlarmEmails.Remove CStr(lTimerIdDummy)
End Select
End Sub
 
Sub subTimerHandler(ByVal lhWnd As Long, ByVal lMsg As Long, ByVal lTimerID As Long, ByVal lTime As Long)
Dim iEmailItemStatus As Integer
Dim strEmailEntryID As String
Dim iMsgBoxResponse As Integer 'Name is in another procedure
Dim iDummy As Integer
If lTimerID < 0 Then
 iEmailItemStatus = "Timer killed"
 subEmailDMR_MsgBox iEmailItemStatus, lTimerID
 Exit Sub
End If
On Error Resume Next
strEmailEntryID = c_MsgAlarmEmails.Item(CStr(lTimerID))(3)
If Err.Number = 5 Then 'lTimerID is not used in collection c_MsgAlarmEmails
On Error GoTo -1 '0
Exit Sub
End If
On Error GoTo -1 '0
iEmailItemStatus = funcEmailNotDMRItemNumber(strEmailEntryID)
If iEmailItemStatus > 0 Then
'Email not move, deleted or read (DMR), so it is there and unread
'Show MsgBox asking to reset alarm
'Stop sound after MsgBox
sndPlaySound32 strResetTimerSoundPathFname, &H9
Dim oAlertedEmail As Outlook.MailItem
Set oAlertedEmail = olInboxFolder.Items.Item(iEmailItemStatus)
iMsgBoxResponse = funcShowSetReminder(oAlertedEmail, lTimerIntervalms, lMsgBoxTimeoutms)
sndPlaySound32 vbNullString, &H9
'Recheck if there since user could have DMR'ed it when msgbox was open
iEmailItemStatus = funcEmailNotDMRItemNumber(strEmailEntryID)
If iEmailItemStatus > 0 Then
'Item in Inbox
'Handle alarm and collection
Select Case iMsgBoxResponse
Case 6, 32000 'Reset alarm by user selection or timeout of msgbox
'timer repeats withou reseting.
Case 7 'Alert is not Rerun
KillTimer 0&, lTimerID
c_MsgAlarmEmails.Remove CStr(lTimerID)
lTimerID = -99999
Case Else
MsgBox "Unknown Error. There should be no other type of response from MsgBox that ask about setting up Alert.", vbOKOnly
End Select
Else
'Alert user with MsgBox about Read
subEmailDMR_MsgBox iEmailItemStatus, lTimerID
End If
Else
'CANNOT use return code iEmailItem from funcEmailNotDMRItemNumber before select
'User could not have DMR or sorted since funcEmailNotDMRItemNumber before select case
'so iEmailItem is NOT valid
'Get email status and alert user with MsgBox about DM
iEmailItemStatus = funcEmailNotDMRItemNumber(strEmailEntryID)
subEmailDMR_MsgBox iEmailItemStatus, lTimerID
End If
End Sub
 
Sub subEmailDMR_MsgBox(iEmailStatus As Integer, lTimerID As Long)
'iEmailItem is the item number in the inbox
'It has been determined that the email has been read or is not in the InBox to get here
Dim strMsgBoxMessage As String
Dim lBoxStyle As Long 'Name is used in other prodcedures
Dim strEntryID As String
Dim strFrom As String
Dim strSubject As String
Dim strReceivedtime As String
Dim strEmailInfo As String
Dim lDummyReturn As Long
Dim strEmailAction As String
strEmailAction = "Read"
 
If bDMRAlert = True Then
'Return code from NotDMR
'>0 item number in Inbox
'0 there but read - Alert user read so handled and timer not reset
'-1 in store but not in Inbox so moved - Alert user moved so handled and timer not reset
'-2 permently deleted - Alert user no longer exists so handled and timer not reset
 
With c_MsgAlarmEmails
strFrom = .Item(CStr(lTimerID))(0) '.SenderName
strSubject = .Item(CStr(lTimerID))(1) '.Subject
strReceivedtime = .Item(CStr(lTimerID))(2) '.ReceivedTime
End With
strEmailInfo = strFrom & vbLf _
& strSubject & vbLf _
& strReceivedtime & vbLf _
& " "
Select Case iEmailStatus
Case Is > 0 'Email in Inbox and unread.
MsgBox "The email is in the Inbox and has not been read. This message should never occur!" & vbLf _
& strEmailInfo
Case 0 'Read and in InBox
strMsgBoxMessage = "Email has been read and assumed handled." & vbLf _
& "Timer was not set or reset." & vbLf _
& strEmailInfo
Case -1 'Moved (may have to check if Deleted Items is in store
strMsgBoxMessage = "Email has been moved from InBox and assumed handled." & vbLf _
& "Timer was not set or reset." & vbLf _
& strEmailInfo
strEmailAction = "Moved"
Case -2 'Deleted - No info may be available for MsgBox
strMsgBoxMessage = "Email has been permentaly deleted and assumed handled." & vbLf _
& "Timer was not set or reset." & vbLf _
& strEmailInfo
strEmailAction = "Deleted"
Case Else
End Select
lBoxStyle = vbOKOnly + vbInformation + vbDefaultButton1 + vbSystemModal + vbMsgBoxSetForeground
sndPlaySound32 strSetTimerErrorSoundPathFname, &H9
'Get Moved Read Deleted DMR timed out
lDummyReturn = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lMsgBoxTimeoutms)
sndPlaySound32 vbNullString, &H9
End If
'Remove timer from collection by key
If lTimerID > -1 Then
KillTimer 0&, lTimerID
c_MsgAlarmEmails.Remove CStr(lTimerID)
lTimerID = -99999 'This seems to be the only 1 used.
End If
End Sub
 
Function funcEmailNotDMRItemNumber(ByVal strEmailEntryID As String) As Integer
'DMR Delete, Moved, Read
Dim olMailItem As Object
Dim I As Integer
'Return code
'>0 item number in Inbox
'0 there but Read
'-1 in store but not in Inbox so Moved
'-2 permanently deleted
 
'Check if Email there and is Unread
funcEmailNotDMRItemNumber = 0
'If InBox sorted by date most recent to oldest I will have the Item number if found
'numbering from bottom (1) to top (## item is status bar)
For I = olInboxFolder.Items.Count To 1 Step -1
If olInboxFolder.Items.Item(I).EntryID = strEmailEntryID Then Exit For 'I has item's number on list so is there
Next I
If I > 0 Then
'Item in Inbox (True)
funcEmailNotDMRItemNumber = I 'There and assumed unread
If olInboxFolder.Items.Item(I).UnRead = False Then funcEmailNotDMRItemNumber = 0 'There but is read
Else
'Item not in Inbox (False)
'Check if item is in Store
On Error Resume Next
Set olMailItem = Session.GetItemFromID(strEmailEntryID)
If Err.Number = 0 Then
'Wrong if move to different forlder the EntryID is changed so can't tell if moved or deleted!!!
funcEmailNotDMRItemNumber = -1 'Item is in Store, Not in InBox
Else
funcEmailNotDMRItemNumber = -2 'Item not in Store so permanently deleted
End If
On Error GoTo -1 '0
End If
Set olMailItem = Nothing
End Function
 
Function funcShowSetReminder(ByVal oNewEmail As Outlook.MailItem, lTimerIntervalms As Long, lMsgBoxTimeoutms As Long) As Integer
'Show Message Box to set reminder timer
Dim strMsgBoxMessage As String
Dim lBoxStyle As Long 'Name is used in other prodcedures
Dim iMsgBoxButton As Integer
Dim iDefaultButton As Integer
Dim intMsgBoxTimeoutResponse As Integer
 
'MsgBox string for Timer
Dim lMsgBoxTimerIntervalSec As Long
Dim strMsgBoxTimerInterval As String
Dim strMsgBoxTimerUnits As String
Dim strMsgBoxTimerTimeUnits As String
 
'MsgBox string for MsgBox Timeout
Dim lMsgBoxTimeOutSec As Long
Dim strMsgBoxTimeOut As String
Dim strMsgBoxTimeOutUnits As String
Dim strMsgBoxTimeOutTimeUnits As String
 
'MsgBox Style enumerations 5 groups: button, icon, default button, modal type, other
'vbYesNo = 4
'vbQuestion = 32
'vbDefaultButton1 = 0 (Yes if YesNo)
'vbSystemModal = 4096 Require response before going back to application
'vbApplicationModal = 0 Alternate modal if System Modal too intrusive
'vbMsgBoxSetForeground = 65536 'put msgbox in front of all windows
lBoxStyle = vbYesNo + vbQuestion + vbDefaultButton1 + vbSystemModal + vbMsgBoxSetForeground
 
lMsgBoxTimerIntervalSec = lTimerIntervalms / 1000
lMsgBoxTimeOutSec = lMsgBoxTimeoutms / 1000
 
Select Case lMsgBoxTimerIntervalSec
Case 0 '< 1 second
strMsgBoxTimerInterval = CStr(lMsgBoxTimerIntervalSec)
strMsgBoxTimerUnits = " second"
strMsgBoxTimerTimeUnits = "<" & strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case 1 '1 second
strMsgBoxTimerInterval = CStr(lMsgBoxTimerIntervalSec)
strMsgBoxTimerUnits = " second"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case 2 To 59 '0.5 to 1.5 minutes
strMsgBoxTimerInterval = CStr(lMsgBoxTimerIntervalSec)
strMsgBoxTimerUnits = " seconds"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case 60 '1 minute
strMsgBoxTimerInterval = CStr(lMsgBoxTimerIntervalSec / 60)
strMsgBoxTimerUnits = " minute"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case 61 To 90 'Between 1-1.5 minutes
strMsgBoxTimerInterval = CStr(lMsgBoxTimerIntervalSec)
strMsgBoxTimerUnits = " seconds"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case 91 To 3569 '1.5 to 59 minutes
strMsgBoxTimerInterval = CStr(Round(lMsgBoxTimerIntervalSec / 60, 0))
strMsgBoxTimerUnits = " minutes"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case 3570 To 5399 '1 hour
strMsgBoxTimerInterval = CStr(Round(lMsgBoxTimerIntervalSec / 3600, 0))
strMsgBoxTimerUnits = " hour"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case Is >= 5400 '>1 hour
strMsgBoxTimerInterval = CStr(Round(lMsgBoxTimerIntervalSec / 3600, 0))
strMsgBoxTimerUnits = " hours"
strMsgBoxTimerTimeUnits = strMsgBoxTimerInterval & strMsgBoxTimerUnits
Case Else
strMsgBoxTimerInterval = CStr(lMsgBoxTimerIntervalSec)
strMsgBoxTimeOutTimeUnits = "(Unknow error on timer interval milliseconds - " & strMsgBoxTimerInterval & ")"
End Select
 
Select Case lMsgBoxTimeOutSec
Case 0 '< 1 second
strMsgBoxTimeOut = CStr(lMsgBoxTimeOutSec)
strMsgBoxTimeOutUnits = " second"
strMsgBoxTimeOutTimeUnits = "<" & strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case 1 '1 second
strMsgBoxTimeOut = CStr(lMsgBoxTimeOutSec)
strMsgBoxTimeOutUnits = " second"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case 2 To 59 '0.5 to 1.5 minutes
strMsgBoxTimeOut = CStr(lMsgBoxTimeOutSec)
strMsgBoxTimeOutUnits = " seconds"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case 60 '1 minute
strMsgBoxTimeOut = CStr(lMsgBoxTimeOutSec / 60)
strMsgBoxTimeOutUnits = " minute"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case 61 To 90 'Between 1-1.5 minutes
strMsgBoxTimeOut = CStr(lMsgBoxTimeOutSec)
strMsgBoxTimeOutUnits = " seconds"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case 91 To 3569 '1.5 to 59 minutes
strMsgBoxTimeOut = CStr(Round(lMsgBoxTimeOutSec / 60, 0))
strMsgBoxTimeOutUnits = " minutes"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case 3570 To 5399 '1 hour
strMsgBoxTimeOut = CStr(Round(lMsgBoxTimeOutSec / 3600, 0))
strMsgBoxTimeOutUnits = " hour"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case Is >= 5400 '>1 hour
strMsgBoxTimeOut = CStr(Round(lMsgBoxTimeOutSec / 3600, 0))
strMsgBoxTimeOutUnits = " hours"
strMsgBoxTimeOutTimeUnits = strMsgBoxTimeOut & strMsgBoxTimeOutUnits
Case Else
strMsgBoxTimeOut = CStr(lMsgBoxTimeOutSec)
strMsgBoxTimeOutTimeUnits = "(Unknow error on message box time out milliseconds - " & strMsgBoxTimeOut & ")"
End Select
 
strMsgBoxMessage = "Repeat email reminder in " & strMsgBoxTimerTimeUnits & "?" & vbLf _
& "From: " & oNewEmail.SenderName & vbLf _
& "Subject: " & oNewEmail.Subject & vbLf _
& "(Default Yes and closes in " & strMsgBoxTimeOutTimeUnits & ")" & vbLf _
& " "
 
funcShowSetReminder = MsgBoxTimeout(0, strMsgBoxMessage, "Email Message!", lBoxStyle, 0, lMsgBoxTimeoutms)
'Return code is Yes = 6, No = 7, timeout = 32000
'While MsgBox up user could Delete, Move or Read email and
'it needs to be checked before putting it in collection
End Function
 
Sub subDebugAndLogCodeExample(Optional Void As Integer)
'Debug.Print activation code
Dim strModName As String
Dim vInfo As Variant 'Can be whatever variable type you want
strModName = "subDebugAndLogCodeExample"
vInfo = "What ever you want to see"
If bMailMsgAlarmDebugPrint = True Then
Debug.Print strModName, vInfo
End If
 
'Log to file activation code
If bMailMsgAlarmLog = True Then
 n = FreeFile()
Open strFolderFileLog For Append As #n 'strFolderFileLog Define in Declarations
Print #n, Now()
Print #n, strModName, vInfo
Close #n
'End If
End Sub
 
Sub subUseAudioDevice(strAudioDevice As String, strAudioDeviceTestSoundPathFname As String)
'Sound notes
'&H1 asynchronous - does not wait to finish sound before continuing code
'&H8 play as loop until next call to sndPlaySound
'&H's can be combined as &H9, this plays asynchronously and continuously until sound is stopped
'Example
'Play sound
'sndPlaySound32 strAudioDeviceTestSoundPathFname, &H9
'Kill sound for testing
'sndPlaySound32 vbNullString, &H9
 
Dim lWaitForDeviceToChange As Long 'millisecs
Dim strAudioDeviceBatFile As String
Dim strShellCmd As String
'Needed or there is not enough time for bat/vbs script to change device output
lWaitForDeviceToChange = 2000
 
Select Case strAudioDevice
Case UCase("No Change")
Exit Sub
Case UCase("HeadPhones")
strAudioDeviceBatFile = strAudioDeviceHeadphonesBatFile
Case UCase("Speakers")
strAudioDeviceBatFile = strAudioDeviceSpeakersBatFile
Case UCase("Ask")
strAudioDevice = funcChoseAudioDevice
strAudioDeviceBatFile = strAudioDeviceHeadphonesBatFile
If strAudioDevice = "SPEAKERS" Then strAudioDeviceBatFile = strAudioDeviceSpeakersBatFile
Case Else
'Msg Box Bad strAudioDevice , alert and default strAudioDevice
End Select
 
'If playing sound, have to kill sound or it won't change device
sndPlaySound32 vbNullString, &H9
'Have to change audio output before starting sound otherwise it won't change output device
Dim vPID As Variant 'Prog Task ID
vPID = Shell("explorer.exe """ & strAudioDeviceBatFile & "", vbHide) 'vbNormalFocus 'vbHide does not seem to work
Sleep lWaitForDeviceToChange 'Allows sound setting in Windows to change
'Test if changed
sndPlaySound32 strAudioDeviceTestSoundPathFname, &H9
Sleep lChangeAudioTestTimems
sndPlaySound32 vbNullString, &H9
End Sub
 
Function funcChoseAudioDevice() As String
'Speaker vs Headphones
Dim iUseSpeakerMsgBoxResponse As Integer
Dim strMessageUseSpeaker As String
Dim lBoxStyle As Long 'Name is used in other prodcedures
 
strMessageUseSpeaker = "Do you want to play the new email alerts though" & vbLf _
& "the speaker?" & vbLf _
& "(Default is headphone and closes in 30 seconds)" & vbLf _
& " "
lBoxStyle = vbYesNo + vbQuestion + vbDefaultButton1 + vbSystemModal + vbMsgBoxSetForeground
'Remove "'" in line below if sound is wanted to bring attention to MsgBox
'sndPlaySound32 strMsgBoxSoundPathFname, &H9 'funcPlaySound (strMsgBoxSoundPathFname)
iUseSpeakerMsgBoxResponse = MsgBoxTimeout(0, strMessageUseSpeaker, "Email Sound Source!", lBoxStyle, 0, lMsgBoxSpeakerHeadphonesTimeoutms)
sndPlaySound32 vbNullString, &H9
Select Case iUseSpeakerMsgBoxResponse
Case 6 'Yes
funcChoseAudioDevice = UCase("Speakers")
Case 7, 32000 'No or timeout, default is set to no for all non-yes cases
funcChoseAudioDevice = UCase("HeadPhones")
Case Else
MsgBox "Unknown input error for 'Email Sound Source!' message box." & vbLf _
& "Message box response = " & iUseSpeakerMsgBoxResponse & "." & vbLf _
& "Set audio output to headphonses.", vbOKOnly
funcChoseAudioDevice = UCase("HeadPhones")
End Select
End Function
 
Batch and VBS Code for Selecting Output Device
To select headphones – run bat file that runs VBS file
SetSoundToHeadphone.bat
@Echo OFF
explorer ms-settings:sound
ping -n 2 127.0.0.1 >NUL
CSCRIPT "D:\Users\JAWjr\Documents\Home\HouseItems\Computer\Devices\Sound\SetSoundToHeadPhone.vbs"
SetSoundToHeadPhone.vbs
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.SendKeys "{UP}{ENTER}"
WshShell.SendKeys "%{F4}"
Set WshShell = Nothing
 
To select speakers – run bat file that runs vbs file
SetSoundToSpeaker.bat
@Echo OFF
explorer ms-settings:sound
ping -n 2 127.0.0.1 >NUL
CSCRIPT "D:\Users\JAWjr\Documents\Home\HouseItems\Computer\Devices\Sound\SetSoundToSpeaker.vbs"
SetSoundToSpeaker.vbs
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.SendKeys "{UP}{DOWN}{ENTER}"
WshShell.SendKeys "%{F4}"
Set WshShell = Nothing
 
TIMER CODE IN OUTLOOK
Popup
Sub MBT() 'MsgBoxTimeout that did not work in Outlook
Dim MsgBoxTimedClose As Object, MsgBoxTimedCloseButton As Integer
Set MsgBoxTimedClose = CreateObject("WScript.Shell")
MsgBoxTimedCloseButton = MsgBoxTimedClose.PopUp("Close after 2 seconds", 2, "MsgBoxTitle", 0)
End Sub
 
This MsgBox did NOT close after 2 seconds.
MsgBox 2 WScript.CreateObject("WScript.Shell").Popup
 
Timer Test 1
Sub TestTimer1()
'https://support.microsoft.com/en-us/office/timer-function-46da243c-2570-4950-a818-6d6934bf584a
Dim PauseTime, Start, Finish, TotalTime
'If (MsgBox("Press Yes to pause for 5 seconds", _
4)) = vbYes Then
PauseTime = 5 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
'DoEvents ' Yield to other processes.
Debug.Print Timer
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
MsgBox "Paused for " & TotalTime & " seconds"
'Else
'End
'End If
End Sub
 
 
MsgBox 3 Timer Code Output
 
Timer Test 2
Sub TestTimer2()
MsgBox Timer
End Sub
 
MsgBox 4 Alternate Timer Test OutPut
 
EXAMPLE 64 BIT ENVIRONMENT (never used)
Code(4, 5)
' windows api timer functions
#If VBA7 And WIN64 Then
' 64-bit
Public Declare PtrSafe Function SetTimer Lib "user32" ( _
ByVal HWnd As LongLong, ByVal nIDEvent As LongLong, _
ByVal uElapse As LongLong, _
ByVal lpTimerFunc As LongLong) As LongLong
Public Declare PtrSafe Function KillTimer Lib "user32" ( _
ByVal HWnd As LongLong, _
ByVal nIDEvent As LongLong) As LongLong
#Else
'32-bit
Public Declare Function SetTimer Lib "user32" ( _
ByVal HWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
ByVal HWnd As Long, _
ByVal nIDEvent As Long) As Long
#End If
 
GLOSSARY
DMR                            deleted, moved and/or read

REFERENCES - External Links and Citations
[1]     https://stackoverflow.com/questions/4274103/display-a-message-box-with-a-timeout-value
[2]     https://www.pinvoke.net/default.aspx/user32/MessageBoxTimeout.html
[3]     https://stackoverflow.com/questions/20816881/how-to-show-a-message-box-for-a-specified-time
[4]     https://www.mrexcel.com/board/threads/auto-closing-a-message-box-using-vba-code.1003362/
[5]     https://ramblings.mcpher.com/classes/promises-in-vba/settimer-and-vba/
[6]     https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/declare-statement
[7]     https://www.itninja.com/question/how-to-change-default-sound-device-for-all-users
[8]     https://social.microsoft.com/Forums/en-US/9ebd7ad6-a460-4a28-9de9-2af63fd4a13e/programatically-setting-the-default-playback-device-and-recording-device?forum=windowspro-audiodevelopment
[9]     https://www.codeproject.com/Articles/31836/Changing-your-Windows-audio-device-programmaticall
[10]    http://www.microsoftnow.com/2013/05/creating-a-shortcut-to-change-the-default-audio-device-in-windows.html
[11]    https://www.vbsedit.com/html/f482c739-3cf9-4139-a6af-3bde299b8009.asp
[12]    https://forums.slipstick.com/threads/97962-wshshell-popup-doest-timeout/
[13]    http://www.vboffice.net/en/developers/api-timer/ 

No comments:

Post a Comment

Subscribe to: Posts (Atom)

Post Labels

Search This Blog