none
export Outlook e-mail items to Excel RRS feed

  • Question

  • I get webform emails sent to me with sales contact info in them. I need to use VBA to transfer this information to Excel Contact sheet. Can anyone help me with the code.

    Date: 19.10.2015 17:55

    Name: Susan

    Email: nomail03 at yahoo.com

    Phone: xxxxxxxxxx

    Fax:

    Address:

    City: Trinity

    State: Texas

    Zip Code: 75862

    Timeline: ASAP

    Budget: $30,000

    Comments/Questions:

    I Would Like More Information About Cavco Cabin

    the excel workbook is "Contact Spread Sheet" Sheet1

    I would like outlook to execute every time an email comes into the "Lead" Folder. 

    The email comes into my "Inbox" then "PMH" then goes to "Leads" so it is the leads sub mailbox i would like to transfer data from.

    Wednesday, October 21, 2015 8:16 PM

Answers

  • I assume that the line Const strWorkBookName As String = "C:\Users\RonGreen\Desktop\Customers\contactspreadsheet.xlsm" is all on one line and not broken as displayed here, and that you retained the FileExists function that was in the earlier listing. The module should contain only the following. This is a straight lift from my PC.
    Option Explicit
    
    Sub TestScript()
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.item(1)
        CopyToExcel olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    
    Sub CopyToExcel(olItem As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strWorkSheetName As String = "Sheet1"
    Const strWorkBookName As String = "C:\Users\RonGreen\Desktop\Customers\contactspreadsheet.xlsm"
        'Use FileExists function to determine the availability of the workbook
        If Not FileExists(strWorkBookName) Then Exit Sub
        'Get Excel if it is running, or open it if not
        On Error Resume Next
    
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            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(strWorkBookName)
        Set xlSheet = xlWB.Sheets("Sheet1")
    
        'Process the message
        With olItem
            sText = olItem.Body
            vText = Split(sText, Chr(13))
            'Find the next empty line of the worksheet
            rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1
    
            'Check each line of text in the message body
            For i = UBound(vText) To 0 Step -1
                If InStr(1, vText(i), "Source:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("A" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Date:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("B" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Name:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("C" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Email:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("D" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Phone:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("E" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Address:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("F" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "City:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("G" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "State:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("H" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Zip Code:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("I" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Comments/Questions:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("J" & rCount) = Trim(vItem(1))
                End If
    
            Next i
            xlWB.Save
        End With
        xlWB.Close SaveChanges:=True
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub
    
    Public Function FileExists(ByVal Filename As String) As Boolean
    Dim nAttr As Long
        On Error GoTo NoFile
        nAttr = GetAttr(Filename)
        If (nAttr And vbDirectory) <> vbDirectory Then
            FileExists = True
        End If
    NoFile:
    End Function
    
    


    Graham Mayor - Word MVP
    www.gmayor.com


    Sunday, October 25, 2015 5:54 AM

All replies

  • Something like this should do it for you.

    http://officetricks.com/outlook-email-download-to-excel/


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Wednesday, October 21, 2015 10:18 PM
  • This has been covered many times in this forum. The salient points are covered at http://www.gmayor.com/extract_data_from_email.htm and http://www.gmayor.com/extract_email_data_addin.htm



    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, October 22, 2015 7:39 AM
  • Hi Graham, thanks for the help. I installed the word Addin and it keeps trying to process all the mail on two accounts. I can't seem to make it only look at the Leads folder. Also my contacts spreadsheet in excel is Macro Enabled and it won't see it as an excel worksheet. I'm very new to VBA and have only done a few userforms in excel so i'm not sure I understand it enough to write VBA code for outlook or if it will even work the way my mailboxes are setup. My work email and personal email are in the same outlook 2013. all the mail comes into my personal email then with the use of rules it is sent to my work mailboxes. I setup the work email address as the default but it doesn't seem to make a difference. 
    Thursday, October 22, 2015 10:54 PM
  • Ok Graham, this is what i did with the code. I have a couple of errors i can't figure out. Can you help me with them, I set up the rule to run the script when a new email comes into the Leads Folder.               Compile Error: Expected: list Separator or )

    ub CopyToExcel(olItem at MailItem)

    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strWorkSheetName As String = "Sheet1"
    Const strWorkBookName As String = "C:\Users\RonGreen\Desktop\Customers\contactspreadsheet.xlsm"

    'Use FileExists function to determine the availability of the workbook
    If Not FileExists(contactspreadsheet.xlsm)

    Then Exit Sub
    'Get Excel if it is running, or open it if not
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
    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(contactspreadsheet)
    Set xlSheet = xlWB.Sheets("Sheet1")

    'Process the message
    With olItem
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
    If InStr(1, vText(i), "Source:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("A" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Date:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("B" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Name:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("C" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Email:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("D" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Phone:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("E" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Address:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("F" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "City:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("G" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "State:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("H" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Zip Code:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("I" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Comments/Questions:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("J" & rCount) = Trim(vItem(1))
    End If

    Next i
    xlWB.Save
    End With
    xlWB.Close SaveChanges:=True
    If bXStarted Then
    xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    End Sub

    Sub CopyToExcel()
    Public Function FileExists(ByVal Filename As String) As Boolean
    Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
    FileExists = True
    End If
    NoFile:
    End Function


    • Edited by rgreen1976 Friday, October 23, 2015 12:32 AM misspelled word
    Friday, October 23, 2015 12:10 AM
  • The title of the sub should be

    Sub CopyToExcel(olItem as MailItem)

    and not

    ub CopyToExcel(olItem at MailItem)


    Near the top of your code you have

    If Not FileExists(contactspreadsheet.xlsm)
    Then Exit Sub

    Those two lines should be one line and should read

    If Not FileExists(strWorkBookName) Then Exit Sub

    Similarly a few lines later you have

    Set xlWB = xlApp.Workbooks.Open(contactspreadsheet)

    which should read

    Set xlWB = xlApp.Workbooks.Open(strWorkBookName)

    Near the bottom of your code listing you have

    Sub CopyToExcel()
    Public Function FileExists(ByVal Filename As String) As Boolean

    The line

    Sub CopyToExcel()

    should not be there



    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, October 23, 2015 4:34 AM
  • Ok Now i'm getting Compile Error: Constant Expression Required If Not FileExists(strWorkBookName) Then Exit Sub

    Sub CopyToExcel(o1Item As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strWorkSheetName As String = "Sheet1"
    Const strWorkBookName As String = "C:\Users\RonGreen\Desktop\Customers\contactspreadsheet.xlsm"
    'Use FileExists function to determine the availability of the workbook
    If Not FileExists(strWorkBookName) Then Exit Sub
    'Get Excel if it is running, or open it if not
    On Error Resume Next

    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
    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(strWorkBookName)
    Set xlSheet = xlWB.Sheets("Sheet1")

    'Process the message
    With olItem
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
    If InStr(1, vText(i), "Source:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("A" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Date:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("B" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Name:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("C" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Email:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("D" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Phone:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("E" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Address:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("F" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "City:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("G" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "State:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("H" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Zip Code:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("I" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Comments/Questions:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("J" & rCount) = Trim(vItem(1))
    End If

    Next i
    xlWB.Save
    End With
    xlWB.Close SaveChanges:=True
    If bXStarted Then
    xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    End Sub

    Public Function FileExists(ByVal Filename As String) As Boolean
    Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
    FileExists = True
    End If
    NoFile:
    End Function



    • Edited by rgreen1976 Friday, October 23, 2015 11:38 PM
    Friday, October 23, 2015 11:21 PM
  • The line

    Sub CopyToExcel(o1Item As MailItem)

    should be

    Sub CopyToExcel(olItem As MailItem)

    i.e. lower case L and not the numeral 1

    Use the followig macro to test your script on a selected message in your inbox

    Sub TestScript()
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.item(1)
        CopyToExcel olMsg
    lbl_Exit:
        Exit Sub
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Saturday, October 24, 2015 8:10 AM
  • You can also download selected Outlooks items to CSV file and mix data as you want using this free tool: 

    CodeTwo Outlook Export


    Oskar Shon, Office System MVP - www.VBATools.pl
    if Helpful; Answer when a problem solved

    Saturday, October 24, 2015 1:11 PM
    Answerer
  • Graham, I'm still getting an error,

    Sub CopyToExcel(olItem As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strWorkSheetName As String = "Sheet1"
    Const strWorkBookName As String = "C:\Users\RonGreen\Desktop\Customers\contactspreadsheet.xlsm"
    'Use FileExists function to determine the availability of the workbook
    If Not FileExists(strWorkBookName) Then Exit Sub

    Saturday, October 24, 2015 7:07 PM
  • I assume that the line Const strWorkBookName As String = "C:\Users\RonGreen\Desktop\Customers\contactspreadsheet.xlsm" is all on one line and not broken as displayed here, and that you retained the FileExists function that was in the earlier listing. The module should contain only the following. This is a straight lift from my PC.
    Option Explicit
    
    Sub TestScript()
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.item(1)
        CopyToExcel olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    
    Sub CopyToExcel(olItem As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strWorkSheetName As String = "Sheet1"
    Const strWorkBookName As String = "C:\Users\RonGreen\Desktop\Customers\contactspreadsheet.xlsm"
        'Use FileExists function to determine the availability of the workbook
        If Not FileExists(strWorkBookName) Then Exit Sub
        'Get Excel if it is running, or open it if not
        On Error Resume Next
    
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            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(strWorkBookName)
        Set xlSheet = xlWB.Sheets("Sheet1")
    
        'Process the message
        With olItem
            sText = olItem.Body
            vText = Split(sText, Chr(13))
            'Find the next empty line of the worksheet
            rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1
    
            'Check each line of text in the message body
            For i = UBound(vText) To 0 Step -1
                If InStr(1, vText(i), "Source:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("A" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Date:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("B" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Name:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("C" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Email:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("D" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Phone:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("E" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Address:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("F" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "City:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("G" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "State:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("H" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Zip Code:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("I" & rCount) = Trim(vItem(1))
                End If
    
                If InStr(1, vText(i), "Comments/Questions:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("J" & rCount) = Trim(vItem(1))
                End If
    
            Next i
            xlWB.Save
        End With
        xlWB.Close SaveChanges:=True
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub
    
    Public Function FileExists(ByVal Filename As String) As Boolean
    Dim nAttr As Long
        On Error GoTo NoFile
        nAttr = GetAttr(Filename)
        If (nAttr And vbDirectory) <> vbDirectory Then
            FileExists = True
        End If
    NoFile:
    End Function
    
    


    Graham Mayor - Word MVP
    www.gmayor.com


    Sunday, October 25, 2015 5:54 AM
  • problem solved, Thank you Graham.
    Monday, October 26, 2015 2:18 PM