Can I create an Outlook rule to create a Calendar Alert from Mail message body

Question

What I am trying to do is create an calendar event from mail subject line as below.

If I receive any mail with message body as Due Date:01/01/2015 it should create a event in calendar and also alert me whenever that date and time occurs.

Is this possible by rule or macro? Any help would be much appreciated.

Macro I have tried till now:

Sub CreateAppt(Item As Outlook.MailItem)
Dim newOrder As Outlook.MailItem
Dim thebody As String
Dim date1 As Date
Dim strdate As String
Dim time As String
Dim address As String
Dim TI As Outlook.AppointmentItem

thebody = Item.Body

strdate = Mid(thebody, InStr(1, thebody, "date1: ") + 7, _
InStr(InStr(1, thebody, "date1: "), thebody, vbCrLf) - _
InStr(1, thebody, "date1: ") - 7)

Date = DateSerial(Split(strdate, "/")(2), _
Split(strdate, "/")(1), _
Split(strdate, "/")(0))

time = Mid(thebody, InStr(1, thebody, "time: ") + 5, _
InStr(InStr(1, thebody, "time: "), thebody, vbCrLf) - _
InStr(1, thebody, "time: ") - 5)

address = Mid(thebody, InStr(1, thebody, "address: ") + 7, _
InStr(InStr(1, thebody, "address: "), thebody, vbCrLf) - _
InStr(1, thebody, "address: ") - 7)

Set TI = Application.CreateItem(olAppointmentItem)
With TI
 .Subject = Item.Subject
 .Location = address
 .Start = date1 & time
 .Duration = 0
 .Body = Item.Body
 .ReminderMinutesBeforeStart = 15
 .Save
 '.Display
End With
End Sub

score 1 · Answer 1 · edited Mar 13 '15 at 08:43

I found this clue over at the MSDN blogs. I haven't done any coding in years, but maybe this will help you out.

by Felix Boehme 19 Jun 2013 4:46 PM

Option Explicit

Dim item As Object

Sub NewMeetingReadingPane()

   Set item = Application.ActiveExplorer.Selection(1)

   NewMeetingRequestFromEmail

End Sub

Sub NewMeetingOpenEmail()

   Set item = Application.ActiveInspector.CurrentItem

   NewMeetingRequestFromEmail

End Sub

' Create a New Meeting request from an email

' Written by Michael S. Scherotter (mischero@microsoft.com)

' 1. If the current item is an email, create a new appointment item

' 2. Copy the categories, body, and subject

' 3. Copy the attachments

' 4. Add the sender as a meeting participant

' 5. Add each email recipient as a meeting participant

' 6.    Each To: participant will be required

' 7.    Each CC: or BCC: participant will be optional

Sub NewMeetingRequestFromEmail()

   Dim app As New Outlook.Application

   'Dim item As Object

   'Set item = app.ActiveInspector.CurrentItem

   'Set item = Application.ActiveExplorer.Selection(1)

   If item.Class <> olMail Then Exit Sub

   Dim email As MailItem

   Set email = item

   Dim meetingRequest As AppointmentItem

   Set meetingRequest = app.CreateItem(olAppointmentItem)

   meetingRequest.Categories = email.Categories

   'meetingRequest.Body = email.Body

   meetingRequest.Subject = email.Subject

   meetingRequest.Attachments.Add item, olEmbeddeditem

'    Dim attachment As attachment

'    For Each attachment In email.Attachments

'        CopyAttachment attachment, meetingRequest.Attachments

'    Next attachment

   Dim recipient As recipient

   Set recipient = meetingRequest.Recipients.Add(email.SenderEmailAddress)

   recipient.Resolve

   For Each recipient In email.Recipients

       RecipientToParticipant recipient, meetingRequest.Recipients

   Next recipient

   meetingRequest.MeetingStatus = olMeeting

   Dim inspector As inspector

   Set inspector = meetingRequest.GetInspector

   'inspector.CommandBars.FindControl

   inspector.Display

End Sub

Private Sub RecipientToParticipant(recipient As recipient, participants As Recipients)

   Dim participant As recipient

   If LCase(recipient.Address) <> LCase(Session.CurrentUser.Address) Then

       Set participant = participants.Add(recipient.Address)

       Select Case recipient.Type

       Case olBCC:

           participant.Type = olOptional

       Case olCC:

           participant.Type = olOptional

       Case olOriginator:

           participant.Type = olRequired

       Case olTo:

           participant.Type = olRequired

       End Select

       participant.Resolve

   End If

End Sub

Private Sub CopyAttachment(source As attachment, destination As Attachments)

   On Error GoTo HandleError

   Dim filename As String

   filename = Environ("temp") & "\" & source.filename

   source.SaveAsFile (filename)

   destination.Add (filename)

   Exit Sub

HandleError:

   Debug.Print Err.Description

End Sub

Can I create an Outlook rule to create a Calendar Alert from Mail message body

1 Answers1