VBA Adding New Appointment

Mar 31, 2010
Reaction score
I have setup a rule at work for my groupwise to automatically forward a new appointment to my email on Outlook at home. I am trying to create VBA coding to then take the email and turn it into an appointment. The problem I am running into is that the appointment is a text attachment on the email. Basically, I need my coding to parse through the attachment to gather the details and create the appointment. The code belows works great at parsing the email message and creating an appointment, but I need it to parse the attachment for the information. I hope this makes sense.

	Sub NewMeetingRequestFromEmail()
	Dim app As New Outlook.Application
	Dim Item As Object
	Dim strId As String
	Dim oNameSpace As Outlook.NameSpace
	Dim Item2 As Outlook.MailItem
	Dim objSender As Outlook.AddressEntry
	Dim oMailItem As Outlook.MailItem
	Dim oFolder As Outlook.MAPIFolder
	Dim oMsg As Object
	Dim strBody As String
	Dim unreadmailitems As Outlook.Items
	Dim unreadmailitem As Outlook.MailItem
	Dim meetingRequest As Outlook.AppointmentItem
	Dim I As Integer
	Dim email As MailItem
	Dim bodyarray() As String
	Dim x As Integer
	Dim Y As Integer
	Dim ApptCount As Integer
	Dim ApptCheck As String
	Dim Duration As Integer
	Dim startDay, startTime, endTime, postcode, bodystring, Location As String
	Dim attachment As Outlook.attachment
'* point to the name space
Set oNameSpace = Application.GetNamespace("MAPI")
'* set a reference to the inbox folder
Set oFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set unreadmailitems = oFolder.Items
'* loop through the inbox
'For Each Item In oFolder.Items
For Each unreadmailitem In unreadmailitems
Set Item = unreadmailitem
	 If unreadmailitem.SenderEmailAddress = "[email="[email protected]"][email protected][/email]" And unreadmailitem.SentOnBehalfOfName = "Justin Bledsoe" Then
		If Item Is Nothing Then Exit Sub
		If Item.Class <> olMail Then Exit Sub
		 Set email = Item
		 bodystring = Item.Body
		 bodyarray = Split(bodystring, Chr(10))
			If Mid(bodyarray(0), InStr(bodyarray(0), "Item Type: ") + 12, 11) = "Appointment" Then
			' get meeting start day and time (line 7) preceded by "Appt Date:"
				 x = InStr(bodyarray(1), "day, ")
				 x = x + 5
					startDay = Mid(bodyarray(1), x, 11)
				 x = x + 13
					startTime = Mid(bodyarray(1), x, 10)
			' set meeting end time (add 1 hour to the start time and watch out for 09h/19h)
				 Duration = InStr(bodyarray(2), "Duration:")
				 Duration = Duration + 11
				 Y = Mid(bodyarray(2), Duration, 1)
				If Y < 9 Then
					 Y = Y + Mid(startTime, 1, 2)
					 If Y < 10 Then
							 endTime = "0" & Y & ":00:00" & Mid(startTime, 9, 2)
							 endTime = Y & ":00:00pm"
				End If
			 Y = Mid(startTime, 1, 2)
			 Y = Y + 1
			 endTime = Y & Mid(startTime, 3)
			 Y = InStr(bodyarray(3), "Place:")
			 Y = Y + 7
			 Location = Mid(bodyarray(3), Y)
' get postcode use last bit of 12th line next line is a divider, followed by "Employed:"
' it can vay from 3 characters to 9 characters, and is always preceded by ", "
				meetingRequest.Start = startDay & " " & startTime
				meetingRequest.End = startDay & " " & endTime
				meetingRequest.Subject = postcode & " - " & meetingRequest.Subject
				meetingRequest.ReminderSet = False
				meetingRequest.Categories = "Advent"
				meetingRequest.Location = Location
				meetingRequest.Categories = email.Categories
				meetingRequest.Body = bodystring 'email.Body
				meetingRequest.Subject = email.Subject
			End If
	For Each attachment In email.Attachments
		CopyAttachment attachment, meetingRequest.Attachments
	Next attachment
	Dim recipient As recipient
		Set recipient = meetingRequest.Recipients.Add(email.SenderEmailAddress)
	For Each recipient In email.Recipients
		RecipientToParticipant recipient, meetingRequest.Recipients
	Next recipient
	Dim inspector As inspector
	Item.UnRead = False
End If
End If
Next unreadmailitem
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
	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
	Debug.Print Err.Description
End Sub


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question