none
Export email body to Excel RRS feed

  • Question

  • Hi,

    I'm fairly new to writing VBA, but managed to find the code below from one of the posts someone else made on here, then modified it to extract what I needed. I've posted both codes so it can be seen what I have changed. When I run my code, it does kind of work but it doesn't move onto the next line. I always end up with the last selected emails data on line 2, suggesting to me that it is overwrighting itself and not moving to the next line. I can't see what would be causing that in the code, so any help would be greatly appreciated.

    Old code from http://social.msdn.microsoft.com/Forums/en-US/f1ab97d9-8fef-46cc-bbe0-e597370ed1c2/export-content-from-outlook-2010-emails-to-excel-spreadsheet?forum=isvvba

    Option Explicit
    Sub CopyToExcel()
    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 = "D:\My Documents\Vehicles.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("Sheet1")
    '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), "Source:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Customer Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Customer Email:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Customer Phone:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Move Date:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Origin City:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("F" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Origin State:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("G" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Origin Zip:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Destination City:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Destination State:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("J" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Destination Zip:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("K" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Vehicle Type:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("L" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Vehicle Year:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("M" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Vehicle Make:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("N" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Vehicle Model:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("O" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Vehicle Condition:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("P" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Comments:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("Q" & rCount) = Trim(vItem(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

    My edited version

    Option Explicit 
     
    Sub CopyToExcel() 
        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 = "C:\test.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("Sheet1") 
         
         '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), "mailfieldFromAddress:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("A" & rCount) = Trim(vItem(1)) 
                End If 
                 
                If InStr(1, vText(i), "name:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("B" & rCount) = Trim(vItem(1)) 
                End If 
                 
                If InStr(1, vText(i), "university:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("C" & rCount) = Trim(vItem(1)) 
                End If 
                 
                If InStr(1, vText(i), "course:") > 0 Then 
                    vItem = Split(vText(i), Chr(58)) 
                    xlSheet.Range("D" & rCount) = Trim(vItem(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

    Thanks,

    Tim

    Monday, December 9, 2013 12:09 PM

All replies

  • Found the issue. Hadn't put the colum titles in the file, so it didn't have a first line to base it on.

    I do now have another query though. When we ran the macro, we recieved an error saying that something set on the server wouldn't let us process that many at a time. Is there a way to impliment into the code to process say the first 25 of the selected emails, then the next 25 and so forth.

    Thanks,
    Tim

    Monday, December 9, 2013 3:51 PM
  • Why not just select a smaller group?

    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, December 10, 2013 10:06 AM
  • Hi Graham,

    Thanks for the response. I know that selecting a smaller group would work, but i'm trying to run the code on over 4000 emails. I need to either make the code close each email after it has processed it and then select the next one, or process a batch of emails then close all of those before processing the next batch.
     
    Thanks,
    Tim 

    Tuesday, December 10, 2013 12:46 PM