Solved

Related Question - ID: 39880730 Outlook Rule Runs vb Code

Posted on 2014-03-02
9
251 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
0
Comment
Question by:rogerdjr
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
  • 2
9 Comments
 
LVL 46

Expert Comment

by:aikimark
ID: 40118875
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
 
LVL 46

Expert Comment

by:aikimark
ID: 40118885
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
 
LVL 59

Assisted Solution

by:Chris Bottomley
Chris Bottomley earned 500 total points
ID: 40119709
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
 

Author Comment

by:rogerdjr
ID: 40130179
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
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 40130828
Source wb.close
Xlapp.quit

Chris
0

Featured Post

Free learning courses: Active Directory Deep Dive

Get a firm grasp on your IT environment when you learn Active Directory best practices with Veeam! Watch all, or choose any amount, of this three-part webinar series to improve your skills. From the basics to virtualization and backup, we got you covered.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article lists the top 5 free OST to PST Converter Tools. These tools save a lot of time for users when they want to convert OST to PST after their exchange server is no longer available or some other critical issue with exchange server or impor…
Outlook for dependable use in a very small business   This article is about using the Outlook application (part of Microsoft Office) in a very small business, or for homeowners where dependability and reliability are critical requirements. This …
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…
A short tutorial showing how to set up an email signature in Outlook on the Web (previously known as OWA). For free email signatures designs, visit https://www.mail-signatures.com/articles/signature-templates/?sts=6651 If you want to manage em…

636 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question