none
Code works for internal emails, but not for external emails 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 this 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 8:30 PM

All replies

  • If you are going to run it as a script from a rule, it needs several changes, and I am surprised you got any results when you ran it thus. The required changes are in bold type.

    Option Explicit
     
    Sub LcnToExcel(olItem As Outlook.MailItem)
     Dim xlApp As Object
     Dim xlWB As Object
     Dim xlSheet As Object
      'Dim olItem As Outlook.MailItem ' Remove this line
     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 the message
      'For Each olItem In Application.ActiveExplorer.Selection 'Remove this line
         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 'Remove this line
     xlWB.Close SaveChanges:=True
     If bXStarted Then
         xlApp.Quit
     End If
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
     End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, December 17, 2013 9:44 AM