Related Question - ID: 39880730 Outlook Rule Runs vb Code

rogerdjr
rogerdjr used Ask the Experts™
on
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

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2014

Commented:
1. I do not think you want to try opening the workbook if there is an error.
2. branching inside an If...End If structure is ill advised.
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

Open in new window

3. If there is an error, you probably don't know about it and should comment your On Error statement while you are debugging/testing your code.
4. Depending on usage, integer data type are subject to overflow issues, since they have a 32k max value.
    Dim                    i As Integer
   
    Dim RowNo As Integer, MaxRows As Integer

Open in new window

5. What is your run-time environment?
Top Expert 2014

Commented:
6. Your slow performance is probably caused by your iteration.
While RowNo <= MaxRows

Open in new window

You invoked a find method in the (parameter) mailitem earlier in the code.  Why not invoke a find method on an Excel range object to find your match?
7. If you are invoking this MyRule routine in a loop, you are taking a performance hit by opening the workbook with each invocation.
8. the xlApp variable is not defined (in this routine). Is it a global variable?
9. I do not see where you close the workbook. This could cause you to have many open instances of the workbook in memory which would eventually cause you to use your virtual memory.
10. The While loop does not stop iterating when you get a match.
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011
Commented:
Without changing or analysing anything else I would agree looping is the fundamental issue whether in word or excel itself.  The following change grabs the used range and sets it into an array then cycles the array data ... I think I changed your cell references correctly but I'm only human so please double check:
  arr(i, 0) is your column B datum and  arr(i, 1) the column c datum:

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 arr as variant
    
    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")
        arr = sourcews.Range("B1:C" & sourcews.usedrange.Rows.Count)
        sourceWB.Close
    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 & arr(i, 0) & vbNewLine & arr(i, 1) & vbNewLine & i
            For i = LBound(arr) To UBound(arr)
                    MsgBox "Second " & vbNewLine & Item.Subject & vbNewLine & Item.SenderEmailAddress & vbNewLine & NameFilter & vbNewLine & objContactsFolder.Name & vbNewLine & objContact.Email1Address & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & vbNewLine & arr(i, 0) & vbNewLine & arr(i, 1) & vbNewLine & i
                
                If Item.SenderEmailAddress = elem 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 & arr(i, 0) & vbNewLine & arr(i, 1) & vbNewLine & i
                    objContact.Body = objContact.Body & vbNewLine & "--------------------" & vbNewLine & Format(Item.ReceivedTime, "mm/dd/yyyy") & " " & Item.Subject & vbNewLine & arr(i, 1)
                    objContact.Save
                End If
                
                RowNo = RowNo + 1
            Next
        End If
NoContactFound:
MsgBox "NoContactFound" & vbNewLine & NameFilter
End Sub

Open in new window


Chris

Author

Commented:
Chris Bottomley

Thanks  - the change you suggested works fine

A slight problem I will have to deal with is that it seems to keep the spreadsheet open at the end of the process - I'll have to find a way to close the spreadsheet when I exit outlook.
Software Quality Lead Engineer
Top Expert 2011
Commented:
Source wb.close
Xlapp.quit

Chris

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial