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.
Code:
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)
Else
endTime = Y & ":00:00pm"
End If
Else
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)
recipient.Resolve
For Each recipient In email.Recipients
RecipientToParticipant recipient, meetingRequest.Recipients
Next recipient
Dim inspector As inspector
meetingRequest.Save
Item.UnRead = False
Item.Delete
End If
Else
Item.Delete
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
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