We help IT Professionals succeed at work.
Get Started

Related Question - ID: 39880730 Outlook Rule Runs vb Code

290 Views
Last Modified: 2014-06-13
I am making progress on implementing a solution based on the excellent input I got on the 1st question.

I adapted this code trying to open excel and search for a matching email then select the folder name (or names) for each instance of that email and append that to the contact item in outlook.

Two issues:
  1) Opening and searching excel like I do is slow - I wonder if there is a faster way to search a list?
 2) I added the "On Error GoTo NoContactFound"  line because the code was failing at "If objContact.Class = olContact Then" when there was no matching email address in the contacts folder - now id doesn't find the email matches but jumps to the end.

Sub MyRule(Item As Outlook.MailItem)
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim obj As Object
    
    Dim NameFilter As String, strFile As String, i As Integer
   
    Dim RowNo As Integer, MaxRows As Integer
    
    Set xlApp = CreateObject("Excel.Application")

    If xlApp = "Microsoft Excel" Then
    
    Else
        With xlApp
            .Visible = True
            .EnableEvents = False
        End With
    End If
    
    strFile = "C:\Personal\OutlookData\OutlookRuleFileEmails.xlsm"
On Error GoTo openit
    If sourceWB.Name <> "OutlookRuleFileEmails.xlsm" Then
openit:
        Set sourceWB = xlApp.Workbooks.Open(strFile) ', , False, , , , , , , True)
        Set sourceWS = sourceWB.Worksheets("EmailRule")
        sourceWB.Activate
    End If
    
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactsFolder.Items

    NameFilter = "[Email1Address] = " & """" & Item.SenderEmailAddress & """"
    
    Set objContact = objItems.Find(NameFilter)
    
On Error GoTo NoContactFound
    
        If objContact.Class = olContact Then
        
'-----------------
MsgBox "First " & vbNewLine & Item.Subject & vbNewLine & Item.SenderEmailAddress & vbNewLine & NameFilter & vbNewLine & objContactsFolder.Name & vbNewLine & objContact.Email1Address & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & vbNewLine & sourceWS.Cells(i, 2) & vbNewLine & sourceWS.Cells(i, 3) & vbNewLine & i
            RowNo = 1
            MaxRows = sourceWS.Cells(1, 1)
        
            While RowNo <= MaxRows
                    MsgBox "Second " & vbNewLine & Item.Subject & vbNewLine & Item.SenderEmailAddress & vbNewLine & NameFilter & vbNewLine & objContactsFolder.Name & vbNewLine & objContact.Email1Address & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & vbNewLine & sourceWS.Cells(i, 2) & vbNewLine & sourceWS.Cells(i, 3) & vbNewLine & i
                
                If Item.SenderEmailAddress = sourceWS.Cells(i, 2) Then
                    MsgBox "Third " & vbNewLine & Item.Subject & vbNewLine & Item.SenderEmailAddress & vbNewLine & NameFilter & vbNewLine & objContactsFolder.Name & vbNewLine & objContact.Email1Address & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & vbNewLine & sourceWS.Cells(i, 2) & vbNewLine & sourceWS.Cells(i, 3) & vbNewLine & i
                    objContact.Body = objContact.Body & vbNewLine & "--------------------" & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & " " & Item.Subject & vbNewLine & sourceWS.Cells(i, 3)
                    objContact.Save
                End If
                
                RowNo = RowNo + 1
            Wend
        End If
NoContactFound:
MsgBox "NoContactFound" & vbNewLine & NameFilter
End Sub

Open in new window


I'm learning, searching the internet for help, but after a couple of hrs. trying to solve this one I'm stumped
Comment
Watch Question
CERTIFIED EXPERT
Top Expert 2011
Commented:
This problem has been solved!
Unlock 2 Answers and 5 Comments.
See Answers
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE