Function getWeekDayDeltaAfter(intDays As Integer) Dim Days As Integer Dim DayOfWeek As Integer Days = intDays DayOfWeek = DatePart("w", Now() + Days) Do Until (DayOfWeek > 1 And DayOfWeek < 7) Days = Days + 1 DayOfWeek = DatePart("w", Now() + Days) Loop getWeekDayDeltaAfter = Days End Function Sub FupNextDay() FlagForXDays getWeekDayDeltaAfter(1), OlFlagIcon.olBlueFlagIcon, True End Sub Sub ActNextDay() FlagForXDays getWeekDayDeltaAfter(1), OlFlagIcon.olOrangeFlagIcon, True End Sub 'within two hours Sub ActSoon() FlagForXDays 2 / 24, OlFlagIcon.olOrangeFlagIcon, False End Sub Sub FupSoon() FlagForXDays 2 / 24, OlFlagIcon.olBlueFlagIcon, False End Sub Sub Fup2Days() FlagForXDays getWeekDayDeltaAfter(2), OlFlagIcon.olBlueFlagIcon, True End Sub Sub Act2Days() FlagForXDays getWeekDayDeltaAfter(2), OlFlagIcon.olOrangeFlagIcon, True End Sub Sub Def1Days() SnoozeForXDays getWeekDayDeltaAfter(1) End Sub Sub Def2Days() SnoozeForXDays getWeekDayDeltaAfter(2) End Sub Sub Def3Days() SnoozeForXDays getWeekDayDeltaAfter(3) End Sub Sub Def5Days() SnoozeForXDays getWeekDayDeltaAfter(5) End Sub Sub Def10Days() SnoozeForXDays getWeekDayDeltaAfter(10) End Sub Sub Def20Days() SnoozeForXDays getWeekDayDeltaAfter(20) End Sub Sub SnoozeToMonday() SnoozeToWeekDay 0 End Sub Sub SnoozeToTuesday() SnoozeToWeekDay 1 End Sub Sub SnoozeToWednesday() SnoozeToWeekDay 2 End Sub Sub SnoozeToThursday() SnoozeToWeekDay 3 End Sub Sub SnoozeToFriday() SnoozeToWeekDay 4 End Sub Sub SnoozeToWeekDay(intDay As Integer) Dim Item As Object Dim SelectedItems As Selection Dim dtTaskDate As Date If Weekday(Date, vbMonday) - 1 < intDay Then 'we don't need to go to next week dtTaskDate = CStr(DateAdd("h", 9, CDate(Date - ((Date + 5) Mod 7) + intDay))) Else dtTaskDate = CStr(DateAdd("h", 9, CDate(Date + 7 - ((Date + 5) Mod 7) + intDay))) End If Set SelectedItems = Outlook.ActiveExplorer.Selection For Each Item In SelectedItems With Item .FlagDueBy = dtTaskDate .Save End With Next Item End Sub Sub SnoozeForXDays(intDays As Integer) Dim Item As Object Dim SelectedItems As Selection Dim dtTaskDate As Date dtTaskDate = CStr(DateAdd("h", 9, CDate(Format(CDbl(Date) + intDays)))) Set SelectedItems = Outlook.ActiveExplorer.Selection For Each Item In SelectedItems With Item .FlagDueBy = dtTaskDate .Save End With Next Item End Sub Sub FlagForXDays(dblDays As Double, flagIcon As Integer, truncateTime As Boolean) 'Based on code presented at: http://skillzdesign.com/blog/2008/01/02/flag-microsoft-outlook-inbox-items-for-follow-up-script/ 'Modified by Marc Rohde (http://marc.rohde-net.us) to the flag by a number of days. Dim Item As Object Dim SelectedItems As Selection Dim dtTaskDate As Date If truncateTime Then dtTaskDate = CStr(DateAdd("h", 9, CDate(Format(CDbl(Date) + dblDays)))) Else dtTaskDate = CStr(CDate(Format(CDbl(Now) + dblDays))) End If Set SelectedItems = Outlook.ActiveExplorer.Selection For Each Item In SelectedItems With Item .FlagDueBy = dtTaskDate .flagIcon = flagIcon .Save End With Next Item End Sub