CODEWITHSUNDEEP
vbaoutlook
eqiz
eqiz

Reputation: 1591

Auto Create Appointment based on Email

I'm looking to try and have outlook automatically create an appointment based on the Subject line of an incoming email. For instance if I receive an email with the subject line "Demo Downloaded" I want it to create an appointment for this email that shows the body of the message as the "Note" on the Appointment. Also, I want the appointment TIME to be 2 hours after the date of the email was sent to me. So if I received the email at 1pm eastern i want the appointment to be automatically set for 3pm eastern.

I know I need to use VBA and have outlook run a script, which I know how to do all of this. However all I currently know right now is how to manually create an appointment based off the selected email, not the email that has been received. Plus I dont know how to have it automatically set the time or anything fancy like that...

This is currently all I have...

Sub CreateTask(Item As Outlook.MailItem)
    Dim objTask As Outlook.TaskItem
    Set objTask = Application.CreateItem(olTaskItem)
With objTask
    .Subject = Item.Subject
    .StartDate = Item.ReceivedTime
    .Body = Item.Body
    .Save
End With
    Set objTask = Nothing
End Sub

Upvotes: 0

Views: 2249

Answers (2)

niton
niton

Reputation: 9179

In your edited version ...

The mailitem is known from Sub CreateTask(msg As MailItem)

Try replacing

Sub CreateTask(msg As MailItem)
    Dim app As New Outlook.Application
    Dim item As Object
    Set item = GetCurrentItem()
    If item.Class <> olMail Then Exit Sub

    Dim email As MailItem

    Set email = item

    Dim meetingRequest As AppointmentItem

    Set meetingRequest = app.CreateItem(olAppointmentItem)

with

Sub CreateTask(msg As MailItem) 
    Dim meetingRequest As AppointmentItem
    Set meetingRequest = Application.CreateItem(olAppointmentItem)

Replace email with msg everywhere except in .SenderEmailAddress

Upvotes: 1

eqiz
eqiz

Reputation: 1591

I have figured it out after playing around with the code and reading up on a few other things. This is what I came up with.

Sub CreateTask(msg As MailItem)
    Dim app As New Outlook.Application
    Dim item As Object
    Set item = GetCurrentItem()
    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.Start = Date & " " & DateAdd("h", 3, Time)

    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

    Dim inspector As inspector

    Set inspector = meetingRequest.GetInspector

    meetingRequest.Save
    meetingRequest.Send

End Sub

However I have noticed that sometimes I get an error saying that this script can't be loaded. Does anyone know a better method or something I might be missing?

Upvotes: 0

Related Questions