Extract Dates for Appointment Item in Body of email

[Bob Weidman]

Here is my script that runs as a rule as soon as new email's come into the account. What I need is to have the start time and end time being defined in the body of the email. This code does work just need the Dates fixed for the appointment item.

Sub RunscriptMacro(MyMail As MailItem)
NewMeetingRequestFromEmail incoming:=MyMail
End Sub


Sub NewMeetingRequestFromEmail(incoming As MailItem)
Dim objAppt As Outlook.AppointmentItem
Set objAppt = Application.CreateItem(olAppointmentItem)

objAppt.Subject = incoming.Subject
objAppt.Location = incoming.Subject
objAppt.Body = incoming.Body
objAppt.Start = incoming.ReceivedTime
objAppt.End = DateSerial(Year(Now), Month(Now), Day(Now) + 7)



' when is the start date? I want it to be from a datefield in the body of the email after the text "Event Start:"
' when is the end date? I want it to be from a datefield in the body of the email after the text "Event End:"

' save and leave
objAppt.Save
Set objAppt = Nothing
End Sub

 

[Diane Poremsky]

You can use either instr function to find it or regex.

Example using regex: http://www.slipstick.com/developer/regex-parse-message-text/

 

[Bob Weidman]

When I try to implement that then nothing works. Call me confused. I made sure that VBScript Expressions 5.5 is on.

 

[Bob Weidman]

This is what I had put into my code that I wrote above in order to just see if I can change the location in the appointment item from a string in the body of the email.

With Reg1.Pattern = "Location\s*[:]+\s*(\w*)\s*"
.Global = True
End With
If Reg1.test(incoming.Body) Then
Set M1 = Reg1.Execute(incoming.Body)
For Each M In M1
objAppt.Location = M.SubMatches(1)
Next
End If

 

[Diane Poremsky]

do you get any error messages?

 

[Diane Poremsky]

BTW, is there a reason you are using 2 macros instead of just the second one?

 

[Diane Poremsky]

This works. I think the problem was because you need to use two sets of () in the pattern - they don't have to both be together like i did it, but the submatches gets the pattern inside the second set.

Sub RunscriptMacro(MyMail As MailItem)
NewMeetingRequestFromEmail incoming:=MyMail
End Sub


Sub NewMeetingRequestFromEmail(incoming As MailItem)
Dim objAppt As Outlook.AppointmentItem
Dim strLoc As String
Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match

Set objAppt = Application.CreateItem(olAppointmentItem)
    Set Reg1 = New RegExp
   
With Reg1
  .Pattern = "Location\s*[:]+\s*((\w*))\s*"
.Global = True
End With
If Reg1.test(incoming.Body) Then
Set M1 = Reg1.Execute(incoming.Body)
For Each M In M1
strLoc = M.SubMatches(1)
Next
End If
With objAppt

.Subject = incoming.Subject
.Location = incoming.Subject
.Body = incoming.Body
.Start = incoming.ReceivedTime
.End = DateSerial(Year(Now), Month(Now), Day(Now) + 7)
.Location = strLoc
.Display 'Save
End With

Set objAppt = Nothing
End Sub

 

[Diane Poremsky]

this works with 1 set of ()

With Reg1
  .Pattern = "Location\s*[:]+\s*(\w*)\s*"
.Global = True
End With
If Reg1.test(incoming.Body) Then
Set M1 = Reg1.Execute(incoming.Body)
For Each M In M1
strLoc = M
Next
End If

 

[Bob Weidman]

Thank you so much Diane for your help! This does indeed work. I changed the .Display to .Save
Now the next part I need to do is probably set-up CASE statements that would then take Date strings out of the body of the email and put them into the .Start and .End time of the AppointmentItem. Starting that process now. I'll let you know how that goes.

 

[Bob Weidman]

Here is my Case statements but it did not create the Appointment Item

For i = 1 To 3
With Reg1
Select Case i
Case 1
.Pattern = "(Location\s*[:]([\w-\s]*)\s*)\n"
.Global = False
Case 2
.Pattern = "(Start[:][\d]+[\/-][\d]+[\/-][\d])\n"
.Global = False
Case 3
.Pattern = "(End[:][\d]+[\/-][\d]+[\/-][\d])\n"
.Global = False
End Select

End With
If Reg1.Test(incoming.Body) Then
Set M1 = Reg1.Execute(incoming.Body)
For Each M In M1
strLoc = M.SubMatches(1)
Next
End If

Next i
With objAppt

.Subject = incoming.Subject
.Location = incoming.Subject
.Body = incoming.Body
.Start = incoming.ReceivedTime
.End = DateSerial(Year(Now), Month(Now), Day(Now) + 7)
.Location = strLoc
.Start = strLoc
.End = strLoc
.Save 'Save
End With

 

[Forum Admin]

Not sure how this go missed earlier - Did it not create the appointment or not populate the fields?

An FYI - one problem is probably here:
strLoc = M.SubMatches(1)
The 1 in submatches indicated the set of () to use - but it starts at 0. So
.Pattern = "(End[:][\d]+[\/-][\d]+[\/-][\d])\n"
would use strLoc = M.SubMatches(0)

if you just wanted the date values, you'd use this as the pattern
.Pattern = "(End[:]([\d]+[\/-][\d]+[\/-][\d]))\n"
and keep the submatches(1)

Debug.print can be your friend when testing macros - use
strLoc = M.SubMatches(1)
debug.print strLoc

then show the immediate window (Ctrl+G or look on the View menu). if the value of strLoc isn't written to the immediate window, the pattern is wrong.

another problem is here:
.Subject = incoming.Subject
.Location = incoming.Subject
.Body = incoming.Body
.Start = incoming.ReceivedTime
.End = DateSerial(Year(Now), Month(Now), Day(Now) + 7)
.Location = strLoc
.Start = strLoc
.End = strLoc

you're writing then overwriting the start, end and location fields.