Amateur using VBA. I copied and customized this macro a while ago and it
worked until I upgraded to Outlook 2007. What I'm doing is populating contact
fields, name, address, phone, email address from an email that contains info
in the body. The macro still creates a contact and puts it in correct contact
folder but the fields are no longer populated with info. The info I input is
being put correctly into notes section.

I haven't had time to dig in to this. Wonder if anyone can help since I
don't have new books on Outlook 2007 vba to help me. Thanks.
Rita

Macro

Sub WebContactCreateV3()

   Dim objApp As Application
   Dim objNS As NameSpace
   Dim ContactsFolder As MAPIFolder
   Dim TargetFolder As Outlook.MAPIFolder
   Dim oInspector As Inspector
   Dim objItem As Object
   Dim objCurItem As Object
   Dim strBody As String
   Dim strCustnum, strSalePer, strLimits As String
   Dim objContact As ContactItem
   Dim strFirstName As String
   Dim strLastName As String
   Dim strFileAs As String
   Dim strCompany As String

   
   strCustnum = InputBox("Customer Number")
   strSalePer = InputBox("Salesperson")
   strLimits = InputBox("Limits")
   
   Set objApp = Application
   Set objNS = objApp.GetNamespace("MAPI")
   Set oInspector = objApp.ActiveInspector
   Set objItem = oInspector.CurrentItem

   If oInspector Is Nothing Then
       objNS.GetDefaultFolder(olFolderInbox).Items.GetFirst.Display
       Set oInspector = objApp.ActiveInspector
   End If

   oInspector.Activate
   Select Case oInspector.EditorType
       Case olEditorText
           BlnIsHTML = False
           strBody = objItem.Body
           X = InStr(1, strBody, "Name:")
           Y = InStr(1, strBody, "Title:")
           A = X + 6
           B = Y - A
           FullName = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "Company:")
           A = X + 7
           B = Y - A
           JobTitle = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "Address 1:")
           A = X + 9
           B = Y - A
           Company = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "Address 2:")
           A = X + 11
           B = Y - A
           Address1 = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "City:")
           A = X + 11
           B = Y - A
           Address2 = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "State:")
           A = X + 6
           B = Y - A
           City = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "Zipcode:")
           A = X + 7
           B = Y - A
           State = UCase(Mid(strBody, A, B))
           X = Y
           Y = InStr(1, strBody, "Phone:")
           A = X + 9
           B = Y - A
           Zipcode = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "Fax:")
           A = X + 7
           B = Y - A
           Phone = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "Email:")
           A = X + 5
           B = Y - A
           Fax = Mid(strBody, A, B)
           X = Y
           Y = InStr(1, strBody, "SAL B")
           A = X + 7
           B = Y - A
           Cemail = Mid(strBody, A, B)
     End Select
       Set objItem = objApp.ActiveExplorer.Selection.Item(1)
       Set objContact = objApp.CreateItem(olContactItem)
       objContact.FullName = FullName
       objContact.JobTitle = JobTitle
       objContact.CompanyName = Company
       objContact.BusinessAddressStreet = Address1 & Address2
       objContact.BusinessAddressCity = City
       objContact.BusinessAddressState = State
       objContact.BusinessAddressPostalCode = Zipcode
       objContact.BusinessTelephoneNumber = Phone
       objContact.BusinessFaxNumber = Fax
       objContact.Email1Address = Cemail
       objContact.Body = "Cust # " & strCustnum & vbCrLf & "Salesperson: "
& strSalePer & vbCrLf & "Limits: " & strLimits & strBody
       objContact.Categories = "Web Customer"
       With objContact
               strCompany = .CompanyName
               strFirstName = .FirstName
               strLastName = .LastName
               strFileAs = strCompany & " (" & strLastName & ", " &
strFirstName & ")"
               .FileAs = strFileAs
               .Display
           
       End With
     
       objContact.Save
           
   Set objCurItem = Application.ActiveInspector.CurrentItem
   Set ContactsFolder =
Application.Session.GetDefaultFolder(olFolderContacts)
   Set TargetFolder = ContactsFolder.Folders("Web Customers")
   Set objCurItem = objCurItem.Move(TargetFolder)
   
End Sub

What Subject field of email looks like: 2 blank lines then

Account: username
Password: abcdefg
Name: John Doe
Title: Operations Manager
Company: XYZ, Inc.
Address 1: 343 Smith Avenue
Address 2:
City: Anycity
State: PA
Zipcode: 12345
Phone: 555-123-4567
Fax:
Email: custemail@xyz.com
SAL Branch: Crafton
SAL Primary Order Dept: Equipment
View AR: No
View Orders: Yes
View Invoices: Yes
View Items: Yes
Enter Orders: Yes
Change Password: Yes