Outlook 2016 Flag/Reminder On Send

[Pigeon]

Hi all,


Just wondering if someone could help me with the below coding I put together from various sources. I am a complete novice when it comes to coding but managed to get this work ALMOST 100%.

The only problem I have. Is on either of the flags (72 hour, 24 hour or 5PM Same Day) it pops up in the tasks twice. Once as the correct task but also as a 'No Date' set task. When removing the task on either one it removes both...Seems to be double adding? Or is there a bit of code I am missing?
I have 3 seperate buttons to set the different coding flags (SetFlag, SetFlag1, SetFlag2)

Thanks in advance!

Option Explicit
Dim SetFlag
Dim SetFlag1
Dim SetFlag2
Private WithEvents olSentItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub

Private Sub olSentItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
Dim prompt As String
If SetFlag = vbYes Then

With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 3 days
.TaskDueDate = Now + 3
.ReminderSet = True
.ReminderTime = Now + 3
.Save
End With
End If
SetFlag = vbNo

If SetFlag1 = vbYes Then

With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 1 days
.TaskDueDate = Now + 1
.ReminderSet = True
.ReminderTime = Now + 1
.Save
End With
End If
SetFlag1 = vbNo

If SetFlag2 = vbYes Then

With Item
.MarkAsTask olMarkToday
' sets a due date at end of TODAY
.TaskDueDate = Date + TimeValue("05:00:00 PM")
.ReminderSet = True
.ReminderTime = Date + TimeValue("05:00:00 PM")
.Save
End With
End If
SetFlag2 = vbNo

End Sub

Sub SayYes()
SetFlag = vbYes
End Sub

Sub SayYes1()
SetFlag1 = vbYes
End Sub

Sub SayYes2()
SetFlag2 = vbYes
End Sub

[Pigeon]

:(

[gmayor]

I have looked at this a couple of times, and I think the following may be closer to what you need. It seems to work, but ensure your delays are appropriate (1) produces an error which I have not looked into, if you remove the error trap


Option Explicit
Private SetFlag As Long
Private SetFlag1 As Long
Private SetFlag2 As Long
Private WithEvents olSentItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub

Private Sub olSentItems_ItemAdd(ByVal Item As Object)
Dim prompt As String

prompt = InputBox("Get which flag?, 0, 1 or 2")
On Error Resume Next
Select Case prompt
Case 0
SayYes
Case 1
SayYes1
Case 2
SayYes2
Case Else
MsgBox "Invalid entry!"
GoTo lbl_Exit
End Select
MsgBox SetFlag & vbCr & SetFlag1 & vbCr & SetFlag2
Select Case True
Case SetFlag = vbYes
With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 3 days
.TaskDueDate = Date + 3
.ReminderSet = True
.ReminderTime = Date + 3
.Save
End With
SetFlag = vbNo

Case SetFlag1 = vbYes
With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 1 days
.TaskDueDate = Date + 1
.ReminderSet = True
.ReminderTime = Date + 1
.Save
End With
SetFlag1 = vbNo

Case SetFlag2 = vbYes
With Item
.MarkAsTask olMarkToday
' sets a due date at end of TODAY
.TaskDueDate = Date + TimeValue("05:00:00 PM")
.ReminderSet = True
.ReminderTime = Date + TimeValue("05:00:00 PM")
.Save
End With
SetFlag2 = vbNo
End Select
lbl_Exit:
Exit Sub
End Sub

Sub SayYes()
SetFlag = vbYes
SetFlag1 = vbNo
SetFlag2 = vbNo
End Sub

Sub SayYes1()
SetFlag1 = vbYes
SetFlag = vbNo
SetFlag2 = vbNo
End Sub

Sub SayYes2()
SetFlag2 = vbYes
SetFlag = vbNo
SetFlag1 = vbNo
End Sub

[Pigeon]

Hi Gmayor,

Thanks for the reply, appreciate you having a look. This coding brings up a box to ask what flag I want. The coding I was after was how I had set, where I have 3 different buttons in my toolbar and I can click either of those depending on what flag I want. Its only going to be used on about 20% of the e-mails sent so the pop up box is a waste for 80% of the time as flag is not required...

I'm pretty sure its something simple I am missing in my coding as it keeps popping up twice in the task list..




I have looked at this a couple of times, and I think the following may be closer to what you need. It seems to work, but ensure your delays are appropriate (1) produces an error which I have not looked into, if you remove the error trap


Option Explicit
Private SetFlag As Long
Private SetFlag1 As Long
Private SetFlag2 As Long
Private WithEvents olSentItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub

Private Sub olSentItems_ItemAdd(ByVal Item As Object)
Dim prompt As String

prompt = InputBox("Get which flag?, 0, 1 or 2")
On Error Resume Next
Select Case prompt
Case 0
SayYes
Case 1
SayYes1
Case 2
SayYes2
Case Else
MsgBox "Invalid entry!"
GoTo lbl_Exit
End Select
MsgBox SetFlag & vbCr & SetFlag1 & vbCr & SetFlag2
Select Case True
Case SetFlag = vbYes
With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 3 days
.TaskDueDate = Date + 3
.ReminderSet = True
.ReminderTime = Date + 3
.Save
End With
SetFlag = vbNo

Case SetFlag1 = vbYes
With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 1 days
.TaskDueDate = Date + 1
.ReminderSet = True
.ReminderTime = Date + 1
.Save
End With
SetFlag1 = vbNo

Case SetFlag2 = vbYes
With Item
.MarkAsTask olMarkToday
' sets a due date at end of TODAY
.TaskDueDate = Date + TimeValue("05:00:00 PM")
.ReminderSet = True
.ReminderTime = Date + TimeValue("05:00:00 PM")
.Save
End With
SetFlag2 = vbNo
End Select
lbl_Exit:
Exit Sub
End Sub

Sub SayYes()
SetFlag = vbYes
SetFlag1 = vbNo
SetFlag2 = vbNo
End Sub

Sub SayYes1()
SetFlag1 = vbYes
SetFlag = vbNo
SetFlag2 = vbNo
End Sub

Sub SayYes2()
SetFlag2 = vbYes
SetFlag = vbNo
SetFlag1 = vbNo
End Sub

[gmayor]

FWIW it doesn't appear in my task list at all, but the reminders work and the messages are marked appropriately.
This is not my particular area of expertise, but I would have thought that in order for it to appear in the task list you would additionally have to create a task item from the message?
If you don't want the prompt, then change the ThisOutlookSession code to the following. I have commented out the unwanted lines but left in the message box for testing that the flag is set (it will show 6 for vbYes, 7 for vbNo)

Private WithEvents olSentItems As Items

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub

Private Sub olSentItems_ItemAdd(ByVal Item As Object)
'Dim prompt As String

'prompt = InputBox("Get which flag?, 0, 1 or 2")
'On Error Resume Next
'Select Case prompt
'Case 0
' SayYes
'Case 1
' SayYes1
'Case 2
' SayYes2
'Case Else
' MsgBox "Invalid entry!"
' GoTo lbl_Exit
'End Select
MsgBox SetFlag & vbCr & SetFlag1 & vbCr & SetFlag2 'left in for checking
Select Case True
Case SetFlag = vbYes
With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 3 days
.TaskDueDate = Date + 3
.ReminderSet = True
.ReminderTime = Date + 3
.Save
End With
SetFlag = vbNo

Case SetFlag1 = vbYes
With Item
.MarkAsTask olMarkThisWeek
' sets a due date in 1 days
.TaskDueDate = Date + 1
.ReminderSet = True
.ReminderTime = Date + 1
.Save
End With
SetFlag1 = vbNo

Case SetFlag2 = vbYes
With Item
.MarkAsTask olMarkToday
' sets a due date at end of TODAY
.TaskDueDate = Date + TimeValue("05:00:00 PM")
.ReminderSet = True
.ReminderTime = Date + TimeValue("05:00:00 PM")
.Save
End With
SetFlag2 = vbNo
End Select
lbl_Exit:
Exit Sub
End Sub

and put the following in an ordinary module
Option Explicit
Public SetFlag As Long
Public SetFlag1 As Long
Public SetFlag2 As Long

Sub SayYes()
SetFlag = vbYes
SetFlag1 = vbNo
SetFlag2 = vbNo
End Sub

Sub SayYes1()
SetFlag1 = vbYes
SetFlag = vbNo
SetFlag2 = vbNo
End Sub

Sub SayYes2()
SetFlag2 = vbYes
SetFlag = vbNo
SetFlag1 = vbNo
End Sub