I have updated to code to add below items --
1. Start date – date of receiving email
2. Due date – start date + 3
3. Reminder to turn on
4. Reminder date – Due date
1: Option Compare Text
2:
3: Sub MakeWaitingForTaskWithAttachmentFromCurrentMessage(MyMail As Outlook.MailItem)
4: Dim strID As String
5: Dim olNS As Outlook.NameSpace
6: Dim olMail As Outlook.MailItem
7: Dim objTask As Outlook.TaskItem
8: Dim categories As String
9: Dim addRecipient As Boolean
10: Dim regex
11: Dim matches, customSubject, subject
12:
13: ' Configuration options
14: categories = "@WAITING FOR"
15: addRecipient = True
16:
17: strID = MyMail.EntryID
18: Set olNS = Application.GetNamespace("MAPI")
19: Set olMail = olNS.GetItemFromID(strID)
20: Set objTask = Application.CreateItem(olTaskItem)
21: objTask.Attachments.Add MyMail
22: Set regex = CreateObject("vbscript.regexp")
23: regex.Pattern = "/wf (.*)"
24: regex.IgnoreCase = True
25: regex.Global = True
26: Set matches = regex.Execute(olMail.Body)
27: If matches.Count <> 0 Then
28: customSubject = matches(0).submatches(0)
29: Else
30: customSubject = ""
31: End If
32: If customSubject <> "" Then
33: subject = customSubject
34: Else
35: subject = olMail.subject
36: End If
37:
38: With objTask
39: If addRecipient Then
40: .subject = olMail.Recipients.item(1) & ": " & subject
41: Else
42: .subject = subject
43: End If
44: .categories = categories
45: .Body = olMail.Body
46: .StartDate = olMail.ReceivedTime
47: .DueDate = olMail.ReceivedTime + 3
48: .ReminderSet = True
49: .ReminderTime = olMail.ReceivedTime + 3
50:
51: End With
52: objTask.Save
53:
54: Set objTask = Nothing
55: Set olMail = Nothing
56: Set olNS = Nothing
57: End Sub
58:
59: ' Wrapper that gets the current item and calls the previous function, to use as a macro
60: Sub MakeWaitingForTaskWithAttachmentFromCurrentMessageMacro()
61: Dim curMail As Outlook.MailItem
62: Set curMail = GetCurrentItem()
63: Call MakeWaitingForTaskWithAttachmentFromCurrentMessage(curMail)
64: End Sub
65:
66:
67:
68: Function GetCurrentItem() As Object
69: Dim objApp As Outlook.Application
70:
71: Set objApp = CreateObject("Outlook.Application")
72: On Error Resume Next
73: Select Case TypeName(objApp.ActiveWindow)
74: Case "Explorer"
75: Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
76: Case "Inspector"
77: Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
78: Case Else
79: ' anything else will result in an error, which is
80: ' why we have the error handler above
81: End Select
82:
83: Set objApp = Nothing
84: End Function
This code is for waiting for category.