Play sounds when the event starts in Outlook

setReminderSounds.vb

Option Explicit

Const SOUND_FILE_LOCATION As String = "C:\Users\Demuyt\Documents\REMINDER.WAV"
Const ACTION_CUTOFF_IN_SECONDS As Integer = 1600

Sub setMeetingReminderSounds()
    
    Dim reminder    As reminder
    Dim appointment As AppointmentItem
    Dim secondsLeft As Long
    Dim status      As String
    
    For Each reminder In Application.reminders
        
        Set appointment = reminder.Item
        
        secondsLeft = DateDiff("s", Now, appointment.start)
        If secondsLeft > 0 And secondsLeft < ACTION_CUTOFF_IN_SECONDS Then
            
            If Not appointment.ReminderOverrideDefault Then
                appointment.ReminderOverrideDefault = True
                appointment.ReminderPlaySound = True
                appointment.ReminderSet = True
                appointment.ReminderSoundFile = SOUND_FILE_LOCATION
                appointment.Save
                status = "Updated"
            Else
                status = "Upcoming"
            End If
            'Give some feedback on what's coming up
            Debug.Print status & "; " & reminder.Caption, appointment.start, secondsLeft & " seconds left"
        End If
        DoEvents 'Good manners
    Next
    
End Sub