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:

http://msdn2.microsoft.com/en-us/library/bb208315.aspx
- The full list of Business Contact UserProperties can be found at:

http://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
'////////////////////////////////////////////////////////////////////////