Finding a date in message body and using it to set a reminder in outlook calendar - vba

Question

Currently I have a macro running on all sent items to check that checks to see if I'm sending the e-mail to a particular customer. If I am, then it checks to see if one of the customer’s requirements for all messages is present which is a 'next update due' if it is not it asks if one is required. See below;
Public Sub application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim addrType
Dim addr
Dim recip
For Each recip In Item.Recipients
If recip.Type = olTo Then
addrType = recip.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3002001F")
If addrType = "EX" Then
addr = recip.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
addr = recip.Address
End If
If LCase(addr) = "relevantemail1#outlook.com" Or LCase(addr) = "relevantemail2#outlook.com" Then
If InStr(1, Item.Body, LCase("next update due"), vbTextCompare) > 0 Then
Call errhandler
Else
'ask if we've added the date
prompt$ = "You're sending this to company x and have not added a 'next update due' date, do you need to add one?"
If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbYes Then
Cancel = True
End If
Exit For
End If
End If
End If
Next
End Sub
I am still really getting to grips with the basics of outlook VBA and string functions etc therein. so my question is: can I find the string after the text "next update due:" (ideally I want a formatted date but a string will do for the time being)? Essentially there will always be two delimiters ": " to begin the date and a carriage return to end it. Once I can retrieve it I am able to export the relevant information to an excel document which I will however I am struggling with the initial retrieval of the string/date.
Hopefully you guys can help, more than happy to expand on the above code if needed.

Answer 1

relative simple regex might be used to extract particular date pattern from body
"next update due:(*):"
and your result will be captured in those parenthessis
or with specific date formatting:
"next update due:*(\d\d\/\d\d\/\d\d)*:"
if your date is like 10/01/15

Answer 2

I have made a few changes to your code and hopefully it will get you in the right track.
A few observations to help you with the code.
Always break long code into smaller functions to help you
Always declare variables
Always write comments to help you.
Here is the code I hope it helps
Public Sub application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strAddress As String
Dim oRecipient As Recipient
Dim strNextDueDate As String
For Each oRecipient In Item.Recipients
If oRecipient.Type = olTo Then
' Get the address
strAddress = GetAddress(oRecipient)
' Check the adress for de
If HasToBeChecked(strAddress) Then
If InStr(1, Item.Body, LCase("next update due"), vbTextCompare) > 0 Then
'Get the value for the date.
strNextDueDate = GetStringBetweenStrings(Item.Body, "next update due:", vbCr)
' ------------------------------------------
' The rest of your code here.....
' ------------------------------------------
'Call errhandler
Else
'ask if we've added the date
prompt$ = "You're sending this to company x and have not added a 'next update due' date, do you need to add one?"
If MsgBox(prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check Address") = vbYes Then
Cancel = True
End If
Exit For
End If
End If
End If
Next
End Sub
' Fucntion to check if the address should be chnaged.
' We have it as a separate function so we can add more
' emails if needed.
Function HasToBeChecked(ByVal strAddress As String)
Dim arrAddresses As Variant
Dim i As Long
Dim ret As Boolean
' Load the array of addresses
arrAddresses = Array("relevantemail1#outlook.com", "relevantemail2#outlook.com")
For i = LBound(arrAddresses) To UBound(arrAddresses)
If LCase$(strAddress) = LCase$(arrAddresses(i)) Then
ret = True
Exit For
End If
Next i
'Return the value
HasToBeChecked = ret
End Function
' Function to retrive the address from a recipient object
Function GetAddress(ByRef oRecipient As Recipient) As String
Const strSCHEMA_PROPERTY_TYPE As String = "http://schemas.microsoft.com/mapi/proptag/0x3002001F"
Dim strAddresType As String
Dim ret As String
' Get the address accoring to if it's an excahnge or a regular email
strAddresType = oRecipient.PropertyAccessor.GetProperty(strSCHEMA_PROPERTY_TYPE)
If addrType = "EX" Then
ret = oRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
ret = oRecipient.Address
End If
' Return the value
GetAddress = ret
End Function
' Function to get he string between teo strings
Function GetStringBetweenStrings(ByVal strToCheck As String, _
ByVal strStart As String, _
ByVal strEnd As String) As String
Dim lPosStart As Long
Dim lPostEnd As Long
Dim ret As String
lPosStart = InStr(1, strToCheck, strStart)
If Not lPosStart = 0 Then
lPosStart = lPosStart + Len(strStart) + 1
lPostEnd = InStr(lPosStart, strToCheck, strEnd)
If Not lPostEnd = 0 Then
ret = Mid$(strToCheck, lPosStart, lPostEnd - lPosStart)
End If
End If
' Return the value
GetStringBetweenStrings = ret
End Function
Thanks