Related Question - ID: 39880730 Outlook Rule Runs vb Code

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
rogerdjrAsked:
Who is Participating?
 
Chris BottomleyConnect With a Mentor Software Quality Lead EngineerCommented:
Source wb.close
Xlapp.quit

Chris
0
 
aikimarkCommented:
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?
0
 
aikimarkCommented:
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.
0
 
Chris BottomleyConnect With a Mentor Software Quality Lead EngineerCommented:
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
0
 
rogerdjrAuthor 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.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.