none
rule runs script for internal email but not external email RRS feed

  • Question

  • I've got code that exports data from the body of an Outlook email to an Excel spreadsheet.  For instance

    First Name:  Jane
    Last Name:  Doe

    Goes to a spreadsheet as columns A & B (and so on).

    When I run it as a macro, it works perfectly.  When I run it as script from a rule on a test email that I send to myself, it works perfectly. 

    However, when I change the rule to run it when it comes from the external source that actually sends the data, it doesn't work.  It opens the spreadsheet and closes it, but does not leave the data. 

    I'm a relative beginner.  I didn't come up with this code myself but used code provided by Graham Mayor in another forum.

    Any help would be greatly appreciated.

    Deanna Kate

    Specifics below:

    The rule is set up like this:
    Apply this rule after the message arrive
    from emailaddressoforg
    and with Alert for Name of Person in the body
    run Project1.ThisOutlookSession.LcnToExcel

    And here's the code:

    Option Explicit
     
    Sub LcnToExcel(item As Outlook.MailItem)
     Dim xlApp As Object
     Dim xlWB As Object
     Dim xlSheet As Object
     Dim olItem As Outlook.MailItem
     Dim vText As Variant
     Dim sText As String
     Dim vItem As Variant
     Dim i As Long
     Dim rCount As Long
     Dim bXStarted As Boolean
     Const strPath As String = "F:\Access\Client Contact database\Data Entry spreadsheets\LcnEmails.xlsx" 'the path of the workbook
     
    If Application.ActiveExplorer.Selection.Count = 0 Then
         MsgBox "No Items selected!", vbCritical, "Error"
         Exit Sub
     End If
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Data")
     
    'Process each selected record
     For Each olItem In Application.ActiveExplorer.Selection
         sText = olItem.Body
         vText = Split(sText, Chr(13))
         'Find the next empty line of the worksheet
        rCount = xlSheet.UsedRange.Rows.Count
         rCount = rCount + 1
     
        'Check each line of text in the message body
         For i = UBound(vText) To 0 Step -1
             If InStr(1, vText(i), "First Name:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("A" & rCount) = Trim(vItem(1))
             End If
            
            If InStr(1, vText(i), "Last Name:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("B" & rCount) = Trim(vItem(1))
             End If
     
            If InStr(1, vText(i), "Email:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("C" & rCount) = Trim(vItem(1))
             End If
     
            If InStr(1, vText(i), "Phone:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("D" & rCount) = Trim(vItem(1))
             End If
     
            If InStr(1, vText(i), "Location:") > 0 Then
                 vItem = Split(vText(i), Chr(58)) 'Split the whole line at the colon
                 vItem = Split(vItem(1), Chr(44)) 'Split the derived line at the comma
                 xlSheet.Range("E" & rCount) = Trim(vItem(0))
                 xlSheet.Range("F" & rCount) = Trim(vItem(1))
             End If
     
            If InStr(1, vText(i), "Zip Code:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("G" & rCount) = Trim(vItem(1))
             End If
            
            If InStr(1, vText(i), "Details:") > 0 Then
              xlSheet.Range("N" & rCount) = Trim(vText(i + 1))
             End If
         Next i
         xlWB.Save
     Next olItem
     xlWB.Close SaveChanges:=True
     If bXStarted Then
         xlApp.Quit
     End If
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
     Set olItem = Nothing
     End Sub

    Monday, December 16, 2013 6:18 PM

All replies

  • Hello DeannaKate,

    Do you have any other rules set up in Outlook or add-ins?

    First of all, I would recommend breaking long lines of invocations into single ones, for example:

    Application.ActiveExplorer.Selection.Count 
    
    ' transform the long line into the following
    
    Dim explorer as Outlook.Explorer
    Dim selection as Outlook.Selection 
    Set explorer = Application.ActiveExplorer
    Set selection = Application.Selection
    Did you try to debug the code?
    Monday, December 16, 2013 6:33 PM