Automatically Create Leads from Web Forms
Prospective customers often visit a company's web site before doing business. Most web sites display product and service details. From the web site, visitors can request additional product information, explain a custom need, or report an issue. When the user submits a request, the web server can generate an e-mail message to the sales representative with the sender's name and e-mail address on the From line. The e-mail body can display the submitted information on consecutive lines as shown below:
Name: Clinton Ford
E-mail: Clinton@contoso.com
Company: Contoso
Address: 862 Contoso St., Ste. 105
City: Redmond
State: WA
Zip Code: 98052
Phone: 425-555-1212
Source: Web
Comments: I'd like to meet on Wed. to discuss a new project
Comments Continued: Could we also discuss next week’s goals?
Wouldn't it be nice if you could automatically create Leads and Opportunities in Business Contact Manager from these e-mail requests? Below is an Outlook macro to help you do this.
First, test the macro on a sample e-mail form from your web server by creating a button on your Outlook toolbar:
1.) Verify that your security settings will prompt you to run unsigned macros by selecting "Tools | Trust Center..." from the main Outlook window. Then click "Macro Security" and select "Warnings for all macros" and click "OK"
2.) Create a Macro from the main Outlook window by selecting "Tools | Macro | Macros..."
3.) Type "Note" as the Macro Name, then click "Create"
4.) The Visual Basic editing window will open. On the left-hand side is a project navigation pane. Right-click on the top-level item named "Project1" and select "Project1 Properties..."
5.) Change "Project1" to "Business" and click "OK"
6.) In the main code area, you'll see "Sub Note()", followed by "End Sub". Replace those two lines with the VBA script below, then click Save.
7.) Close the Visual Basic window to return to Outlook
8.) Right-click on the Outlook toolbar and click "Customize..."
9.) Select the "Commands" tab, select the "Macro" from the Categories list, then drag "Business.Lead" and "Business.Opportunity" to the standard Outlook toolbar and click "Close" on the "Customize" dialog.
10.) Select an e-mail message, then click the "Business.Lead" button.
You can then automate the process with an Outlook Rule:
1.) Tools | Rules and Alerts... | New Rule
2.) Check Messages when they arrive | Next
3.) Select criteria (e.g. With specific words in the subject or body) | Next
4.) run a script | Select "Business.LeadRule" or "Business.OpportunityRule", then click "OK" | Next
5.) Finish
A couple of additional notes:
- You can also populate BCM custom fields. For example, I customized the Business Contact form by adding a text field named "Interested In"
- I opened the Business Contact form, selected the "Source" drop-down list and clicked "Edit this List..." to add "Word of Mouth" as a Source of Lead
- I created an Outlook rule that runs the "Business.LeadRule" script when an e-mail arrives with "Web Contact Form" in the subject
- Comments are limited to a single line. They cannot contain carriage returns or newlines
- The full list of Outlook Contact ItemProperties can be found at:
https://msdn2.microsoft.com/en-us/library/bb208315.aspx
- The full list of Business Contact UserProperties can be found at:
https://msdn2.microsoft.com/en-us/library/aa431892.aspx
You can populate either Lead or Opportunity fields from the e-mail message. To add a new field:
1.) Increment the number of properties (currently 13) in the MapProperties() function.
2.) Copy and paste an existing set of property attributes
3.) Increment the index on each line to match the number from step 1.
4.) Change the attributes as needed to populate your Opportunity or Lead fields.
'////////////////////////////////////////////////////////////////////////
Const conDelimeter = ":" ' Separates property names from values
Const conPrefix = "" ' Text that should be ignored at top of mail
Const conPostfix = "" ' Text that should be ignored at end of mail
' This function maps e-mail name-value pairs to BCM properties
Function MapProperties() As Variant()
' Change the first number to match the number of properties
' The second number is the number of property attributes
Dim arrProperties(13, 6) As Variant
' 1.) Email
arrProperties(1, 0) = "E-mail" ' Web Form Property Name
arrProperties(1, 1) = "Email1Address" ' Outlook Property Name
arrProperties(1, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(1, 3) = olText ' Outlook data type
arrProperties(1, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(1, 5) = False ' Append to existing property value?
' 2.) Company
arrProperties(2, 0) = "Company" ' Web Form Property Name
arrProperties(2, 1) = "CompanyName" ' Outlook Property Name
arrProperties(2, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(2, 3) = olText ' Outlook data type
arrProperties(2, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(2, 5) = False ' Append to existing property value?
' 3.) Industry
arrProperties(3, 0) = "Industry" ' Web Form Property Name
arrProperties(3, 1) = "Industry" ' Outlook Property Name
arrProperties(3, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(3, 3) = olText ' Outlook data type
arrProperties(3, 4) = False ' Outlook Item Property (or User Prop)?
arrProperties(3, 5) = False ' Append to existing property value?
' 4.) FullName
arrProperties(4, 0) = "Name" ' Web Form Property Name
arrProperties(4, 1) = "FullName" ' Outlook Property Name
arrProperties(4, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(4, 3) = olText ' Outlook data type
arrProperties(4, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(4, 5) = False ' Append to existing property value?
' 5.) BusinessAddressStreet
arrProperties(5, 0) = "Address" ' Web Form Property Name
arrProperties(5, 1) = "BusinessAddressStreet" ' Outlook Property Name
arrProperties(5, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(5, 3) = olText ' Outlook data type
arrProperties(5, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(5, 5) = False ' Append to existing property value?
' 6.) BusinessAddressCity
arrProperties(6, 0) = "City" ' Web Form Property Name
arrProperties(6, 1) = "BusinessAddressCity" ' Outlook Property Name
arrProperties(6, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(6, 3) = olText ' Outlook data type
arrProperties(6, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(6, 5) = False ' Append to existing property value?
' 7.) BusinessAddressState
arrProperties(7, 0) = "State" ' Web Form Property Name
arrProperties(7, 1) = "BusinessAddressState" ' Outlook Property Name
arrProperties(7, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(7, 3) = olText ' Outlook data type
arrProperties(7, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(7, 5) = False ' Append to existing property value?
' 8.) BusinessAddressPostalCode
arrProperties(8, 0) = "Zip Code" ' Web Form Property Name
arrProperties(8, 1) = "BusinessAddressPostalCode" ' Outlook Prop Name
arrProperties(8, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(8, 3) = olText ' Outlook data type
arrProperties(8, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(8, 5) = False ' Append to existing property value?
' 9.) BusinessPhone
arrProperties(9, 0) = "Phone" ' Web Form Property Name
arrProperties(9, 1) = "BusinessTelephoneNumber" 'Outlook Property Name
arrProperties(9, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(9, 3) = olText ' Outlook data type
arrProperties(9, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(9, 5) = False ' Append to existing property value?
' 10.) InterestedIn
arrProperties(10, 0) = "Interest" ' Web Form Property Name
arrProperties(10, 1) = "Interested In" ' Outlook Property Name
arrProperties(10, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(10, 3) = olText ' Outlook data type
arrProperties(10, 4) = False ' Outlook Item Property (or User Prop)?
arrProperties(10, 5) = False ' Append to existing property value?
' 11.) Source of Lead
arrProperties(11, 0) = "Source" ' Web Form Property Name
arrProperties(11, 1) = "Source of Lead" ' Outlook Property Name
arrProperties(11, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(11, 3) = olText ' Outlook data type
arrProperties(11, 4) = False ' Outlook Item Property (or User Prop)?
arrProperties(11, 5) = False ' Append to existing property value?
' 12.) Comments
arrProperties(12, 0) = "Comments" ' Web Form Property Name
arrProperties(12, 1) = "Body" ' Outlook Property Name
arrProperties(12, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(12, 3) = olText ' Outlook data type
arrProperties(12, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(12, 5) = True ' Append to existing property value?
' 13.) Comments Continued
arrProperties(13, 0) = "Comments Continued" ' Web Form Property Name
arrProperties(13, 1) = "Body" ' Outlook Property Name
arrProperties(13, 2) = True ' Lead property (or Opportunity prop)?
arrProperties(13, 3) = olText ' Outlook data type
arrProperties(13, 4) = True ' Outlook Item Property (or User Prop)?
arrProperties(13, 5) = True ' Append to existing property value?
' Return the array
MapProperties = arrProperties
End Function
' Automatically create a Lead for inbound mail items
Sub LeadRule(oMailItem As Outlook.MailItem)
' Make sure we have a valid mail item
If oMailItem Is Nothing Then
Exit Sub
End If
' Get a reference to the MAPI namespace
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
' Get the root BCM folder
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Set olFolders = objNS.Session.Folders
If olFolders Is Nothing Then
MsgBox "Unable to locate BCM root folder"
Exit Sub
End If
Set bcmRootFolder = olFolders("Business Contact Manager")
If bcmRootFolder Is Nothing Then
MsgBox "Unable to get Business Contacts folder"
Exit Sub
End If
' Create a Lead from this e-mail message
Call GetLinkedContact(bcmRootFolder, oMailItem, True)
End Sub
' Automatically create a Lead for inbound mail items
Sub OpportunityRule(oMailItem As Outlook.MailItem)
' Make sure we have a valid mail item
If oMailItem Is Nothing Then
Exit Sub
End If
' Get a reference to the MAPI namespace
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
' Get the root BCM folder
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Set olFolders = objNS.Session.Folders
If olFolders Is Nothing Then
MsgBox "Unable to locate BCM root folder"
Exit Sub
End If
Set bcmRootFolder = olFolders("Business Contact Manager")
If bcmRootFolder Is Nothing Then
MsgBox "Could not locate the 'Business Contact Manager' folder"
Exit Sub
End If
If oMailItem Is Nothing Then
MsgBox "MailItem is not set"
Exit Sub
End If
Dim oParent As Outlook.ContactItem
Set oParent = GetOpportunityParent(bcmRootFolder, _
oMailItem, True)
' If we found a Business Contact or Account,
' save its EntryID and Display Name
If oParent Is Nothing Then
MsgBox ("Unable to create or find Opportunity parent")
Else
' Create an Opportunity and link it to the Lead,
' Business Contact, or Account
Dim newOpportunity As Outlook.TaskItem
Set newOpportunity = CreateOpportunity(oParent, _
oMailItem, _
bcmRootFolder, True)
End If
End Sub
' Create a New Opportunity from the selected Business Contact or E-mail
Sub Opportunity()
' Get a reference to the MAPI namespace
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
' Make sure at least one item is selected
If Application.ActiveExplorer Is Nothing Then
MsgBox "Please select an Outlook folder"
Exit Sub
End If
' Get a reference to the currently selected Outlook folder
Dim currentFolder As Outlook.Folder
Set currentFolder = Application.ActiveExplorer.currentFolder
If currentFolder Is Nothing Then
MsgBox "Please select at least one item"
Exit Sub
End If
' Get the root BCM folder
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Set olFolders = objNS.Session.Folders
If olFolders Is Nothing Then
MsgBox "Unable to get the list of Outlook Session folders"
Exit Sub
End If
Set bcmRootFolder = olFolders("Business Contact Manager")
If bcmRootFolder Is Nothing Then
MsgBox "Unable to locate the 'Business Contact Manager' folder"
Exit Sub
End If
' The parent item's EntryID
Dim parentEntryID As String
parentEntryID = "" ' Initialize to empty string
' The parent item's display name
Dim parentDisplayName As String
parentDisplayName = "" ' Initialize to empty string
' Get a reference to the currently selected item
Dim oItem As Object
Dim oParent As Outlook.ContactItem
Set oParent = Nothing
If Not (Application.ActiveExplorer.Selection Is Nothing) Then
If Application.ActiveExplorer.Selection.Count > 0 Then
Set oItem = Application.ActiveExplorer.Selection(1)
End If
End If
If Not (oItem Is Nothing) Then
Set oParent = GetOpportunityParent(bcmRootFolder, _
oItem, True)
' If we found a Business Contact or Account,
' save its EntryID and Display Name
If Not (oParent Is Nothing) Then
parentEntryID = oParent.EntryID
parentDisplayName = oParent.FullName
End If
End If
' Create an Opportunity and link it to the Lead,
' Business Contact, or Account
Dim newOpportunity As Outlook.TaskItem
Dim oMailItem As Outlook.MailItem
Set oMailItem = Nothing
' If this is an e-mail message, look for a related contact/account
If oItem.MessageClass = "IPM.Note" Then
Set oMailItem = oItem
End If
Set newOpportunity = CreateOpportunity(oParent, _
oMailItem, _
bcmRootFolder, _
False)
If newOpportunity Is Nothing Then
MsgBox "Unable to create Opportunity"
Else
' Display the new Opportunity
newOpportunity.Display (False)
End If
End Sub
' Returns the item if it is a Business Contact or Account,
' otherwise creates a new Lead
Function GetOpportunityParent(bcmRootFolder As Outlook.Folder, _
oItem As Object, _
bSave As Boolean) As Outlook.ContactItem
Set GetOpportunityParent = Nothing
If oItem Is Nothing Then
Exit Function
End If
Dim oContactItem As Outlook.ContactItem
Set oContactItem = Nothing
' Only get EntryID if Business Contact or Account
If oItem.MessageClass = "IPM.Contact.BCM.Contact" Or _
oItem.MessageClass = "IPM.Contact.BCM.Account" Then
' The Contact/Account is the Opportunity parent
Set oContactItem = oItem
Else
Set oContactItem = GetLinkedContact(bcmRootFolder, oItem, bSave)
End If
' Return the parent item
Set GetOpportunityParent = oContactItem
End Function
' Retrieves the existing Business Contact or Account,
' otherwise creates a new Lead
Function GetLinkedContact(bcmRootFolder As Outlook.Folder, _
oItem As Object, _
bSave As Boolean) As Outlook.ContactItem
Set GetLinkedContact = Nothing
If oItem Is Nothing Then
Exit Function
End If
Dim oContactItem As Outlook.ContactItem
Set oContactItem = Nothing
Dim oMailItem As Outlook.MailItem
Set oMailItem = Nothing
' If this is an e-mail message, look for the linked contact/account
If oItem.MessageClass = "IPM.Note" Then
' Locate the corresponding Business Contact or Account
Set oMailItem = oItem
Dim strEmailAddress As String
strEmailAddress = oMailItem.SenderEmailAddress
Set oContactItem = GetContactFromEmail(bcmRootFolder, _
"Business Contacts", strEmailAddress)
' If no matching Business Contact was found,
' look for a matching Account
If oContactItem Is Nothing Then
Set oContactItem = GetContactFromEmail _
(bcmRootFolder, "Accounts", strEmailAddress)
End If
End If
' If neither exists, create a new Lead
If oContactItem Is Nothing Then
Set oContactItem = CreateLeadFromEmail _
(bcmRootFolder, oMailItem, bSave)
' Save the new Lead as needed to generate an EntryID
If Not (oContactItem Is Nothing) And bSave Then
oContactItem.Save
End If
End If
' Return the parent item
Set GetLinkedContact = oContactItem
End Function
' Looks up a Business Contact or Account by e-mail address
Function GetContactFromEmail(bcmRootFolder As Outlook.Folder, _
bcmSubFolder As String, _
strEmailAddress As String) _
As Outlook.ContactItem
Set GetContactFromEmail = Nothing
If bcmRootFolder Is Nothing Or bcmSubFolder = "" Or _
strEmailAddress = "" Then
MsgBox "Unable to Get Contact From Email - missing parameter(s)"
Exit Function
End If
' Locate the Business Contacts folder
Dim oContactsFolder As Outlook.Folder
Set oContactsFolder = _
bcmRootFolder.Folders(bcmSubFolder)
If oContactsFolder Is Nothing Or _
oContactsFolder.Items Is Nothing Then
MsgBox "Unable to get the BCM sub-folder"
Exit Function
End If
' Setup the filter restriction string
Dim strRestriction As String
strRestriction = "[Email1Address] = '" & strEmailAddress & "'"
Dim contacts As Outlook.Items
Set contacts = oContactsFolder.Items.Restrict(strRestriction)
If contacts Is Nothing Then
Exit Function
End If
' Add each contact to the list of Account contacts
Dim oContact As Object
Dim i As Integer
For Each oContact In contacts
' Return the first valid contact item
If Not (oContact Is Nothing) Then
Exit For
End If
Next
Set GetContactFromEmail = oContact
Set contacts = Nothing
Set oContactsFolder = Nothing
End Function
' Creates and displays a Lead. If an e-mail message is selected, the Lead
' fields are populated using the sender's name and e-mail address and
' the e-mail contents are used to populate the Lead fields
Sub Lead()
Dim oLead As Outlook.ContactItem
Set oLead = Nothing
' Get a reference to the MAPI namespace
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
' Get a reference to the currently selected Outlook folder
Dim currentFolder As Outlook.Folder
Set currentFolder = Application.ActiveExplorer.currentFolder
' Get the root BCM folder
Dim olFolders As Outlook.Folders
Dim bcmRootFolder As Outlook.Folder
Set olFolders = objNS.Session.Folders
If olFolders Is Nothing Then
MsgBox "Unable to get the list of Outlook Session folders"
Exit Sub
End If
Set bcmRootFolder = olFolders("Business Contact Manager")
Dim BcmContactItem As Outlook.ContactItem
' Get a reference to the currently selected item
Dim oItem As Object
' Make sure at least one item is selected
If Not (Application.ActiveExplorer Is Nothing) Then
If Not (Application.ActiveExplorer.Selection Is Nothing) Then
If Application.ActiveExplorer.Selection.Count > 0 Then
Set oItem = Application.ActiveExplorer.Selection(1)
End If
End If
End If
' Get existing Lead or create a new one
Set oLead = GetLinkedContact(bcmRootFolder, oItem, False)
' If we found or created a Lead, display it
If Not (oLead Is Nothing) Then
oLead.Display (False)
End If
End Sub
' Creates a Lead from an e-mail message
Function CreateLeadFromEmail(bcmRootFolder As Outlook.Folder, _
oMailItem As Outlook.MailItem, _
bSave As Boolean) _
As Outlook.ContactItem
Set CreateLeadFromEmail = Nothing
Dim oLead As Outlook.ContactItem
Set oLead = Nothing
' Locate the Contacts folder
Dim oContactsFolder As Outlook.Folder
Set oContactsFolder = _
bcmRootFolder.Folders("Business Contacts")
If oContactsFolder Is Nothing Then
MsgBox "Unable to get Business Contacts folder"
Exit Function
End If
' Create a new Lead
Const ContactMessageClass = "IPM.Contact.BCM.Contact"
Dim newLead As Outlook.ContactItem
Set newLead = _
oContactsFolder.Items.Add(ContactMessageClass)
If newLead Is Nothing Then
MsgBox "Unable to Create New Lead from Email"
Exit Function
End If
' Set the Lead flag
Dim oLeadProp As Outlook.UserProperty
Set oLeadProp = _
newLead.UserProperties("Lead")
If (oLeadProp Is Nothing) Then
Set oLeadProp = _
newLead.UserProperties.Add("Lead", _
Outlook.olYesNo, False, False)
End If
oLeadProp.Value = True
' See if we have an e-mail message
If oMailItem Is Nothing Then
If bSave Then
oLead.Save
End If
Else
newLead.FullName = oMailItem.SenderName
newLead.Email1Address = oMailItem.SenderEmailAddress
' Parse other lead information from the web form mail
Call ParseWebForm(oMailItem, bSave, newLead, Nothing)
End If
Set CreateLeadFromEmail = newLead
End Function
' Create an Opportunity and link it to the parent item
Function CreateOpportunity(oParentItem As Outlook.ContactItem, _
oMailItem As Outlook.MailItem, _
bcmRootFolder As Outlook.Folder, _
bSave As Boolean) _
As Outlook.TaskItem
' Initialize result to Nothing
Set CreateOpportunity = Nothing
' Locate the Opportunities folder
Dim opportunitiesFolder As Outlook.Folder
Set opportunitiesFolder = _
bcmRootFolder.Folders("Opportunities")
If opportunitiesFolder Is Nothing Then
MsgBox "Unable to get Opportunities folder"
Exit Function
End If
' Create a new Opportunity
Const OpportunityMessageClass = "IPM.Task.BCM.Opportunity"
Dim oNewOpportunity As Outlook.TaskItem
Set oNewOpportunity = _
opportunitiesFolder.Items.Add(OpportunityMessageClass)
If oNewOpportunity Is Nothing Then
MsgBox "Unable to create opportunity"
Exit Function
End If
' Set the opportunity title
If Not (oMailItem Is Nothing) Then
oNewOpportunity.Subject = Trim(oMailItem.Subject)
End If
' Store the parent EntryID and Display Name
If Not (oParentItem Is Nothing) Then
Dim strParentEntryID As String
Dim strParentDisplayName As String
strParentEntryID = oParentItem.EntryID
strParentDisplayName = oParentItem.FullName
End If
' Verify that we have these parameters
If strParentEntryID <> "" And _
strParentDisplayName <> "" Then
' Link the new Opportunity to the selected BCM item
Dim parentEntityEntryID As Outlook.UserProperty
Set parentEntityEntryID = _
oNewOpportunity.UserProperties("Parent Entity EntryID")
If (parentEntityEntryID Is Nothing) Then
Set parentEntityEntryID = _
oNewOpportunity.UserProperties.Add( _
"Parent Entity EntryID", _
olText, False, False)
End If
parentEntityEntryID.Value = strParentEntryID
' Parent Entry ID
Dim parentEntryID As Outlook.UserProperty
Set parentEntryID = _
oNewOpportunity.UserProperties("Parent Entry ID")
If (parentEntryID Is Nothing) Then
Set parentEntryID = _
oNewOpportunity.UserProperties.Add("Parent Entry ID", _
olKeywords, False, False)
End If
parentEntryID.Value = strParentEntryID
' Parent Display Name
Dim parentDisplayName As Outlook.UserProperty
Set parentDisplayName = _
oNewOpportunity.UserProperties("ParentDisplayName")
If (parentDisplayName Is Nothing) Then
Set parentDisplayName = _
oNewOpportunity.UserProperties.Add("ParentDisplayName", _
olText, False, False)
End If
parentDisplayName.Value = strParentDisplayName
End If
' Parse Opportunity information from the web form mail
Call ParseWebForm(oMailItem, bSave, Nothing, oNewOpportunity)
' Save the new Opportunity as needed
If bSave Then
oNewOpportunity.Save
End If
' Return the new Opportunity
Set CreateOpportunity = oNewOpportunity
End Function
Sub ParseWebForm(oMailItem As Outlook.MailItem, _
bSave As Boolean, _
Optional oParentItem As Outlook.ContactItem, _
Optional oOpportunity As Outlook.TaskItem)
' Get the mail body
Dim strMailBody As String
strMailBody = oMailItem.Body
' Create a Regular Expression Object
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
If RegX Is Nothing Then
MsgBox "Unable to create Regular Expression object"
Exit Sub
End If
' Remove any prefix
If conPrefix <> "" Then
RegX.Pattern = "(?:[`~!@#$%^&*()-_+=\[\]{}<>,.\/?\w\s])*?" & _
conPrefix
RegX.IgnoreCase = True
RegX.Global = False
strMailBody = RegX.Replace(strMailBody, "")
End If
' Remove any postfix
If conPostfix <> "" Then
RegX.Pattern = _
conPostfix & "(?:[`~!@#$%^&*()-_+=\[\]{}<>,.\/?\w\s])+"
RegX.IgnoreCase = True
RegX.Global = False
strMailBody = RegX.Replace(strMailBody, "")
End If
' Validate the delimeter character for use in our regular expression
Dim strDelimeter As String
strDelimeter = Right(conDelimeter, 1)
RegX.Pattern = "[\?\*\+\.\|\{\}\\\[\]\(\)]"
RegX.IgnoreCase = True
RegX.Global = False
Dim colValues As Variant
Set colValues = RegX.Execute(strDelimeter)
If colValues.Count > 0 Then
strDelimeter = "\" & strDelimeter
End If
' Find name-value pairs
RegX.Pattern = "(.*)" & strDelimeter & "[ \t]*(.*)"
RegX.IgnoreCase = True
RegX.Global = True
Set colValues = RegX.Execute(strMailBody)
If colValues Is Nothing Then
Exit Sub
End If
Dim arrProperties() As Variant
arrProperties = MapProperties()
' Make sure we have at least 5 attributes per property
If UBound(arrProperties, 2) < 4 Then
MsgBox ("Missing some property attributes")
Exit Sub
End If
Dim i As Integer
Dim strFormPropName As String
Dim strOLPropName As String
Dim strValue As String
Dim itemProp As Outlook.ItemProperty
Dim userProp As Outlook.UserProperty
Dim iType As Integer
Dim bAppend As Boolean
' Get and save properties
For Each Value In colValues
' Retrieve property name
RegX.Pattern = strDelimeter & "[ \t]*(.*)"
strFormPropName = RegX.Replace(CStr(Value), "")
' Retrieve property value
RegX.Pattern = "(.*)" & strDelimeter & "[ \t]*"
strValue = RegX.Replace(CStr(Value), "")
' Remove any trailing carriage returns
strValue = Replace(strValue, Chr(13), "")
' Remove any trailing form feeds
strValue = Replace(strValue, Chr(10), "")
' Get the property attributes
i = GetPropertyIndex(arrProperties, strFormPropName)
' Save this property value if it has a value and attributes
If strValue <> "" And _
i >= 0 Then
' Get the Outlook propertyName
strOLPropName = arrProperties(i, 1) ' Property name
iType = CInt(arrProperties(i, 3)) ' Item type
bAppend = CBool(arrProperties(i, 5)) ' Append vs. Replace?
' Lead Property and we have a parent
If arrProperties(i, 2) And Not (oParentItem Is Nothing) Then
' ItemProperty
If arrProperties(i, 4) Then
Set itemProp = _
oParentItem.ItemProperties(strOLPropName)
If (itemProp Is Nothing) Then
Set itemProp = _
oParentItem.ItemProperties.Add(strOLPropName, _
arrProperties(i, 3), _
False, False)
End If
SetProperty itemProp, iType, strValue, bAppend
' UserProperty
Else
Set userProp = _
oParentItem.UserProperties(strOLPropName)
If (userProp Is Nothing) Then
Set userProp = _
oParentItem.UserProperties.Add(strOLPropName, _
arrProperties(i, 3), _
False, False)
End If
SetProperty userProp, iType, strValue, bAppend
End If
' Opportunity Property and we have an opportunity
ElseIf Not arrProperties(i, 2) And _
Not (oOpportunity Is Nothing) Then
' ItemProperty
If arrProperties(i, 4) Then
Set itemProp = _
oOpportunity.ItemProperties(strOLPropName)
If (itemProp Is Nothing) Then
Set itemProp = _
oParentItem.ItemProperties.Add(strOLPropName, _
arrProperties(i, 3), _
False, False)
End If
SetProperty itemProp, iType, strValue, bAppend
' UserProperty
Else
Set userProp = _
oOpportunity.UserProperties(strOLPropName)
If (userProp Is Nothing) Then
Set userProp = _
oOpportunity.UserProperties.Add(strOLPropName, _
arrProperties(i, 3), _
False, False)
End If
' Save the property
SetProperty userProp, iType, strValue, bAppend
End If
End If
End If
Next
If Not (oParentItem Is Nothing) And bSave Then
' Save any updates to the parent item
oParentItem.Save
End If
End Sub
' Returns the property attributes for a given property name
Function GetPropertyIndex(arrProperties() As Variant, strPropertyName) _
As Integer
Dim i As Integer
For i = LBound(arrProperties, 1) To UBound(arrProperties, 1)
If strPropertyName = arrProperties(i, 0) Then
GetPropertyIndex = i
Exit Function
End If
Next
GetPropertyIndex = -1
End Function
' Set the Outlook property value
Sub SetProperty(prop As Object, iType As Integer, strValue As String, _
bAppend As Boolean)
On Error Resume Next
' Boolean type
If olYesNo = iType Then
If InStr(1, strValue, "Yes", vbTextCompare) Or _
InStr(1, strValue, "True", vbTextCompare) Then
prop.Value = True
Else
prop.Value = False
End If
' Numeric type
ElseIf olNumber = iType Or _
olInteger = iType Then
prop.Value = CInt(strValue)
' Should we replace the existing string value?
ElseIf Not bAppend Then
prop.Value = strValue
ElseIf prop.Value = "" Then
prop.Value = strValue
' Append to the existing string value
Else
prop.Value = prop.Value & vbCrLf & strValue
End If
If Err.Number <> 0 Then
Dim strPropName As String
strPropName = prop.Name
MsgBox "Unable to set property '" & strPropName & _
"' to value '" & strValue & "'. Please check the property " & _
"type, value, and if it is a UserProperty or ItemProperty."
End If
On Error GoTo 0
End Sub
'////////////////////////////////////////////////////////////////////////