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 Else79: ' 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.