VBA Code to create appointment from email

[brian davis]

I'm trying to modify some code that creates an appointment from a sent email. I would like to modify it to make the subject line of the resulting appointment be: "Email to xxx@xxxx.com " + the original subject line of the email. (i.e. I sent an email to George with the subject line of "Help me", the appointment subject line would be "Email to George@xxx.com - Help me"

If there were multiple recipients, the subject line would only need the 1st email recipient

in the body of the appointment, i would like it to say

email to:
xxx@xxxx.com
yyy@yyyy.com
zzz@zzzz.com

and then insert the body of the original email.



With Diane's help, this is the code that i'm working with to create an appointment from a sent email:

Dim WithEvents olSent As Items
Dim WithEvents calFolder As Outlook.Folder




Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set olSent = Ns.GetDefaultFolder(olFolderSentMail).Items
Set calFolder = Ns.GetDefaultFolder(olFolderCalendar).Folders("Work Diary")
Set Ns = Nothing
End Sub

Private Sub olSent_ItemAdd(ByVal item As Object)
Dim objAppt As Outlook.AppointmentItem
Set objAppt = calFolder.Items.Add(olAppointmentItem)
With objAppt
.Subject = item.Subject
.Start = Now
.End = Now
.Body = item.Body
.Categories = "Email"
.Save
End With

Set objAppt = Nothing

End Sub



Any help would be appreciated.

Brian Davis

 

[Diane Poremsky]

You need to make a string with the recipient's addresses -

Dim strRecip As String
For Each Recipient In item.Recipients
strRecip = strRecip & vbcrlf & Recipient.Address
Next Recipient

then get the first recipient address for the subject and add the string to the body:

With objAppt
.Subject = "email to " & item.recipients(1) & item.Subject
.Start = Now
.End = Now
.Body = strRecipt & vbcrlf & item.Body
.Categories = "Email"
.Save
End With