none
Export Content From Outlook 2010 Emails To Excel Spreadsheet

    Question

  • I don't know the first thing about VBA or Access form creation or anything. I am simply searching for a way to transfer data from the body of my emails to Excel so that I can upload them to Quickbooks. The content comes in the following format:

    Source:  www.website.com

    Customer Name: Sonny

    Customer Email: noemail@pleasecall.com

    Customer Phone: 8885551234

    Move Date: 03/29/2012

    Origin City: Stone Mountain

    Origin State: GA

    Origin Zip: 30083

    Destination City: Beltsville

    Destination State: MD

    Destination Zip: 20704

    Vehicle Type: Car

    Vehicle Year: 1999

    Vehicle Make: Honda

    Vehicle Model: Civic

    Vehicle Condition: Running

    Comments:

    Does anyone know how to move this info? Can someone give me a code & instructions to simply copy&paste?

    Thanks!

    Saturday, March 03, 2012 6:26 AM

Answers

  • The following Outlook macro should do the trick. Copy to a new module in Outlook's vba editor. Change the path of the worksheet as appropriate at the start of the macro.

    Note that the macro will fill the columns of the worksheet starting at A in the order the elements required appear in the list above.

    Select the messages you wish to process and run the macro. In Outlook 2010 you may have to use selfcert.exe to provide a digital signature in order to run the macro.

    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
     rCount = xlSheet.UsedRange.Rows.Count
      For Each olItem In Application.ActiveExplorer.Selection
        sText = olItem.Body
        vText = Split(sText, Chr(13))
        'Find the next empty line of the worksheet
         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


    Graham Mayor - Word MVP
    www.gmayor.com





    • Marked as answer by golions Tuesday, March 06, 2012 8:17 PM
    • Edited by Graham MayorMVP Tuesday, December 02, 2014 5:07 AM
    Monday, March 05, 2012 6:23 AM
  • If the e-mail bodies look like

    "Subject: 70--Cisco SmartNet Service coverage for Enterprise Content Delivery NetworkSolicitation Number: NRC-HQ-12-R-10-0140 Agency: Nuclear Regulatory Commission Office: Office of Administration Location: Division of Contracts Notice Type: Combined Synopsis/Solicitation Posted Date: 8/22/2012 Response Date: 8/27/2012 Set Aside: Total Small Business

     

    Subject: cisco equipment Solicitation Number: N00421-12-T-0591 Agency: Department of the Navy Office: Naval Air Systems Command Location: NAVAIR HQ Notice Type: Combined Synopsis/Solicitation Posted Date: 8/22/2012 Response Date: 8/31/2012 Set Aside: Total Small Business"

    then I am surprised it worked correctly even for the first entry as the split is by paragraph.

    I would suspect something like

    Sub CopyToExcel2()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim vPara As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim sLink As String
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\temp\Documents\Fedbid.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("BidSpeed")

    'Process each selected record
    For Each olItem In Application.ActiveExplorer.Selection
        sText = olItem.Body
        vPara = Split(sText, Chr(13))
        'Find the next empty line of the worksheet

        For i = 0 To UBound(vPara)
            If InStr(1, vPara(i), "Subject:") > 0 Then
                rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
                rCount = rCount + 1
                vText = Split(vPara(i), Chr(58))
                vItem = Split(vText(2) & vText(3), ChrW(34))
                xlSheet.Range("A" & rCount) = Trim(Replace(vText(1), "Solicitation Number", ""))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
                xlSheet.Range("C" & rCount) = Trim(Replace(vText(4), "Office", ""))
                xlSheet.Range("D" & rCount) = Trim(Replace(vText(5), "Location", ""))
                xlSheet.Range("E" & rCount) = Trim(Replace(vText(6), "Notice Type", ""))
                xlSheet.Range("F" & rCount) = Trim(Replace(vText(7), "Posted Date", ""))
                xlSheet.Range("G" & rCount) = Trim(Replace(vText(8), "Response Date", ""))
                xlSheet.Range("H" & rCount) = Trim(Replace(vText(9), "Set Aside", ""))
                xlSheet.Range("I" & rCount) = Trim(vText(10))
            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

    would work

    If not and you want to send me one of these e-mails (use the contact link on my web site) I will investigate over the weekend.


    Graham Mayor - Word MVP
    www.gmayor.com




    Friday, August 24, 2012 5:32 AM

All replies

  • This is a article how export date from selected message.

    Put this code to module in Outlook and select some message.

    If you want to seperate data from message to column in Excel you can look at this articles.

    I wrote about Automation from Outlook to Excel and from Excel to Outlook. - they is not publish yet.

    Look there: my articles, I think that 'll be for couple days


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved


    Saturday, March 03, 2012 2:58 PM
    Answerer
  • The following Outlook macro should do the trick. Copy to a new module in Outlook's vba editor. Change the path of the worksheet as appropriate at the start of the macro.

    Note that the macro will fill the columns of the worksheet starting at A in the order the elements required appear in the list above.

    Select the messages you wish to process and run the macro. In Outlook 2010 you may have to use selfcert.exe to provide a digital signature in order to run the macro.

    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
     rCount = xlSheet.UsedRange.Rows.Count
      For Each olItem In Application.ActiveExplorer.Selection
        sText = olItem.Body
        vText = Split(sText, Chr(13))
        'Find the next empty line of the worksheet
         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


    Graham Mayor - Word MVP
    www.gmayor.com





    • Marked as answer by golions Tuesday, March 06, 2012 8:17 PM
    • Edited by Graham MayorMVP Tuesday, December 02, 2014 5:07 AM
    Monday, March 05, 2012 6:23 AM
  • I can recomend you a tool for extract informaction from object:

    CodeTwo Outlook Export

    CodeTwo Outlook Export


    Oskar Shon, Office System MVP

    Press if Helpful; Answer when a problem solved

    Monday, March 05, 2012 8:33 AM
    Answerer
  • This is perfect!

    Now I just need to figure a way to calculate the distance between ZIP codes in Excel and multiply those figures by a certain $$$ per mile that automatically fills in on the spreadsheet so I can simply contact my leads and be on with it.

    Thanks so much for this part though... thus concludes a three day sleepless indulgence....

    Tuesday, March 06, 2012 8:19 PM
  • Hello,

    This code solved my issue as well, found it after 2-3 days of searching.

    1 question, for my specific use it would be helpful to then "Save As..." with the file name being First and Last Name 

    (my data ranges are thus)

    First Name:

    Initial:

    Last Name:

    Branch:

    Manager:

    Windows Access:

    Windows User to Copy:

    Autopoint Access:

    Autopoint User to Copy:

    Other:

    If i can get it to automatically save as "Firstname Lastname" in the same folder as the original that would be great.

    thank you

    Doug

    Wednesday, August 08, 2012 10:59 PM
  • I'm not the expert, for that see Graham when he gets home in September. However, I know that this code is used to pull the information you need and dump it into the same spreadsheet every time.

    WJM

    Thursday, August 09, 2012 1:06 PM
  • Hi, Iam new here and I just came accross this thread looking for the same answer. I am new to VB and have just started learning it  to get a quote system up and running in excel. I have just about finished my quote system and have another project which involves the same problem detailed above. I have outlook 2010 and am hoping to automate a process for a customer which will take a folder in the inbox (just the one specific  folder) and import the body of the messages to a sheet saved on the pc)

    I have copied the above code to a new module to experiment with this and it has come up with error when debugging

    For Each olItem In Application.ActiveExplorer.Selection (line 34)

    why is it not working??? and if I was to create a button in excel to make the macro run how would I do that. Remember I am very new to this. I am fairly confident in excel VB now but outlook seems to be very different.

    Thursday, August 16, 2012 8:49 AM
  • sorry the error was object variable of with block variable not set Please help me!!!!!

    Thursday, August 16, 2012 8:50 AM
  • Could you provide a copy of the emails you're receiving?


    WJM

    Thursday, August 16, 2012 9:36 AM
  • The original macro is an Outlook macro. Are you trying to run it from Excel?

    The original macro does more or less what you suggest, though is written specifically for the original questioner's message format. Undoubtedly your messages will be different. What is your message format. What part(s) or it do you want to add to your worksheet and where in that worksheet do you want it/them?


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, August 23, 2012 6:27 AM
  • This worked great, with a few exceptions.  It pulled only the first entry from each email I have.  Each email will have multiple "Subject" entries and also included a hyperlink that won't transfer into the spreadsheet ( "it says HYPERLINK..".  Mine will look like this:

    "Subject: 70--Cisco SmartNet Service coverage for Enterprise Content Delivery NetworkSolicitation Number: NRC-HQ-12-R-10-0140 Agency: Nuclear Regulatory Commission Office: Office of Administration Location: Division of Contracts Notice Type: Combined Synopsis/Solicitation Posted Date: 8/22/2012 Response Date: 8/27/2012 Set Aside: Total Small Business

     

    Subject: cisco equipment Solicitation Number: N00421-12-T-0591 Agency: Department of the Navy Office: Naval Air Systems Command Location: NAVAIR HQ Notice Type: Combined Synopsis/Solicitation Posted Date: 8/22/2012 Response Date: 8/31/2012 Set Aside: Total Small Business"

    With a different amount in each email.  Any suggestions on how I can fix that?  Much appreciated in advance

    --Edit:  I modified the first code to match my criteria, and the emails look cleaner.  It didn't really paste too great here

    I'll post my code:

    Option Explicit
    
    Sub CopyToExcel()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\temp\Documents\Fedbid.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("BidSpeed")
    
    '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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
        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), "Subject:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Solicitation Number:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Agency:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Office:") > 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))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Notice Type:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("F" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Posted Date:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("G" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Response Date:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Set Aside:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & 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


    • Edited by waynebunch Thursday, August 23, 2012 11:48 PM
    Thursday, August 23, 2012 11:40 PM
  • If the e-mail bodies look like

    "Subject: 70--Cisco SmartNet Service coverage for Enterprise Content Delivery NetworkSolicitation Number: NRC-HQ-12-R-10-0140 Agency: Nuclear Regulatory Commission Office: Office of Administration Location: Division of Contracts Notice Type: Combined Synopsis/Solicitation Posted Date: 8/22/2012 Response Date: 8/27/2012 Set Aside: Total Small Business

     

    Subject: cisco equipment Solicitation Number: N00421-12-T-0591 Agency: Department of the Navy Office: Naval Air Systems Command Location: NAVAIR HQ Notice Type: Combined Synopsis/Solicitation Posted Date: 8/22/2012 Response Date: 8/31/2012 Set Aside: Total Small Business"

    then I am surprised it worked correctly even for the first entry as the split is by paragraph.

    I would suspect something like

    Sub CopyToExcel2()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim vPara As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim sLink As String
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\temp\Documents\Fedbid.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("BidSpeed")

    'Process each selected record
    For Each olItem In Application.ActiveExplorer.Selection
        sText = olItem.Body
        vPara = Split(sText, Chr(13))
        'Find the next empty line of the worksheet

        For i = 0 To UBound(vPara)
            If InStr(1, vPara(i), "Subject:") > 0 Then
                rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
                rCount = rCount + 1
                vText = Split(vPara(i), Chr(58))
                vItem = Split(vText(2) & vText(3), ChrW(34))
                xlSheet.Range("A" & rCount) = Trim(Replace(vText(1), "Solicitation Number", ""))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
                xlSheet.Range("C" & rCount) = Trim(Replace(vText(4), "Office", ""))
                xlSheet.Range("D" & rCount) = Trim(Replace(vText(5), "Location", ""))
                xlSheet.Range("E" & rCount) = Trim(Replace(vText(6), "Notice Type", ""))
                xlSheet.Range("F" & rCount) = Trim(Replace(vText(7), "Posted Date", ""))
                xlSheet.Range("G" & rCount) = Trim(Replace(vText(8), "Response Date", ""))
                xlSheet.Range("H" & rCount) = Trim(Replace(vText(9), "Set Aside", ""))
                xlSheet.Range("I" & rCount) = Trim(vText(10))
            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

    would work

    If not and you want to send me one of these e-mails (use the contact link on my web site) I will investigate over the weekend.


    Graham Mayor - Word MVP
    www.gmayor.com




    Friday, August 24, 2012 5:32 AM
  • Thanks for the response.  Yea, it pulled the first entry and put it in excel just fine.  I tried yours, but I'm getting a "Subscript out of range" on line  

    vItem = Split(vText(2) & vText(3), ChrW(34))

    Friday, August 24, 2012 4:42 PM
  • This is undoubtedly because the actual message is not exactly in the format described (as indicated in private correspondence). I need to see an original message.

    Graham Mayor - Word MVP
    www.gmayor.com

    Saturday, August 25, 2012 6:24 AM
  • ahh..did you get the email I sent to your website?  I can forward you the message a little later.
    Saturday, August 25, 2012 2:10 PM
  • Yes - I replied to that a while back. Check your junk mail filter.

    Graham Mayor - Word MVP
    www.gmayor.com

    Saturday, August 25, 2012 2:23 PM
  • What does it mean when I get this error message:

    "Compile Error:

    User-defined type not defined"

    And the first line, Sub CopyToExcel(), is highlighted yellow?


    WJM

    Saturday, September 08, 2012 2:34 PM
  • The macro uses early binding to Excel and so you probably haven't set a reference to Excel in the Outlook VBA Tools > References.


    Graham Mayor - Word MVP
    www.gmayor.com

    Saturday, September 08, 2012 2:38 PM
  • Hi Graham,

    i am sorry you ask you this but i can not make is work. can you tell me how can i do this in outlook 2010?

    where to go and how to do?

    thanks & regards

    Thursday, October 04, 2012 7:42 AM
  • What was described was an Outlook macro to work with a specific e-mail format and worksheet. It will only work if your conditions are the same as described.

    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, October 04, 2012 8:14 AM
  • Hi Graham Mayor,

    I also need help, I have the same error using the code 

    "Compile Error:

    User-defined type not defined"

    And the first line, Sub CopyToExcel(), is highlighted yellow

    Saturday, October 06, 2012 9:21 PM
  • Thanks for the post!  This was exactly what I was looking for and it works great.  I only have one smalle issue. 

    The issue lies within my "Submission Date:" field.  The reulsting date is: 2/9/2013 1:25:53 PM in the emial.  I think the Split() is stoping the procedure atfter the 1 in the time.  (i.e. result of macro - 2/9/2013 1)

    Sub CopyToExcel()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "D:\Users\USXXXX\Desktop\Test 1.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("Test")

    '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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
        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), "Category:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

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

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

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

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

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

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

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

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

            'If InStr(1, vText(i), "Engagement Settings:") > 0 Then
             '   vItem = Split(vText(i), Chr(81))
              '  xlSheet.Range("L" & rCount) = Trim(vItem(1))
            'End If

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

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

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

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

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

            If InStr(1, vText(i), "Comments:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("N" & 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

     

     

    Monday, February 11, 2013 3:19 PM
  • The split is at the colon, so what you see is not unexpected. In this case you need to process the result again

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


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, February 12, 2013 5:47 AM
  • Hi Graham,

    Thanks for the quick responce.

    I am somewhat new to VBA, so I appreciate your help.  The solution proposed above seems to go in the opposie direction of what I was looking for.  Sorry if I wasnt clear.  See below:

    Orginal Result: 2/9/2013 1

    New Result (as proposed above) : 2/9/2013

    Desired Result: 2/9/2013 1:25:53 PM

    Each email contains a work item.  At this point, the only unique identifier is the exact time of submission. Therefore, I need the exact time and date, so that it can be used as a primary key.  I have tried various breaks such as the letter M after AM and PM, but havent had much luck.


    Thanks,

    CLP 

    Tuesday, February 12, 2013 12:01 PM
  • Oops! In that case you want

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

    The string is split at the colons - Chr(58) - There are thus four items in this string

    Submission Date  - vitem(0)

    2/9/2013 1 - vItem(1)

    25 - vItem(2)

    and

    53 PM - vItem(3)

    You can lose vItem(0) and re-assemble the rest putting back the colons as you go, then trim the result to remove any leading or trailing spaces. Thus:

    Trim(vItem(1) & ":" & vItem(2) & ":" & vItem(3))


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, February 12, 2013 12:25 PM
  • I would be very grateful for someone's help with my specific question. Every month I receive over 1,000 emails that contain data that I currently have to manually copy and past into Excel. I automatically have the emails diverted to a folder in my Outlook and then every month I go in and paste the contents of each email into a spreadsheet.

    I would be very grateful if someone could help me with VBA code that will take the data from all of the emails and somehow? copy or export it to an excel file. The data in each email comes in the form of a table in the body of the email with the same 8 pieces of information (ie 8 colums with one heading each). Each line in the table represents a transaction and sometimes there will be multiple lines in one email (ie multiple transactions) and other times only one (ie one transaction). Is there a VBA code that can automatically extract the information from all of the emails that I have in this specific outlook folder and auto save it as an excel file??? I am hoping some VBA wizard out there can help me with this!!! :)

    Here is an example of how the data would appear. The headings are always the same, so I wouldnt need to extract those, just the contents under the headings.

    Date From To Amount    Time     ID# Method CRV
    1/1/2013   abc def 1000 1200 1234   ghi jkl
    1/2/2013   abc def 1 1400 1234   ghi jkl
    1/3/2013   abc def 999 2350 1234   ghi

    jkl

    Tuesday, April 23, 2013 12:53 AM
  • This thread explains how to do that. It would be relatively simple to modify it either to run automatically from Outlook as the messages are received, or to process the files in a folder. If you want specific help then post the contents of a message so that we can see how it is formatted.

    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, April 23, 2013 4:46 AM
  •  

    Hi Graham,

    I'm very glad I was able to find this forum, I followed the instructions to export e-mail to excel and works very well. Anyhow.. I'm coming across some e-mails that have some weird table format on them that doesn't let me transfer their content.

    Instead of having all the text on the same row there is a row in between the header and the text, plus the text is always different on some rows (Example:)

    Header1:

    text1 text1 text1 .....

    Header2:

    text2 text2 text2 .....

    Do you know what changes need to be done on the macro to be able to transfer an e-mail row without header to a column in excel.. or the row following a specific header?

    thanks

    Wednesday, April 24, 2013 3:50 PM
  • Take a look at the code at the end of the thread - http://social.msdn.microsoft.com/Forums/en-US/isvvba/thread/73012695-729d-4725-b22c-2f32ca1918c0 which works with a table.

    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, April 25, 2013 5:36 AM
  • I too am running into that issue, because my text entries are presenting on the next line down, as below. So far I've followed your content above, got the Excel reference in order, but am totally new to this, and don't know how to get it to look to the next line. Appreciate any help you can provide! When I run it currently, I get the subscript out of range, run time 9 error. When I hit debug, it's highlighting the following: xlSheet.Range("G" & rCount) = Trim(vItem(1))

    That's the last line before "End If" and I don't know what I'm doing wrong!

    Email Content Example:

    Name

    John Doe

    Mailing Address 1

    1234 First Street

    Address 2

    City, State, Zip

    AnyCity, ST, 12345

    Your E-Mail Address

    anyone@anywhere.com

    Phone Number

    (800)555-1212

    Anticipated Graduation Date

    05/01/2014



    Saturday, May 04, 2013 6:25 AM
  • The operative line that determines which paragraph is split is

    vText = Split(vPara(i), Chr(58))

    however if the text you are trying to extract is not part of a split line, but is on the following line, you cannot use this technique to grab the required text, you need to change the whole of the section as follows. This should work provided there are no empty paragraphs between the items, in which case you will have to adjust the numbering at vPara(i + 1) to ensure that the correct paragraph is read.

    For i = 0 To UBound(vPara)

            If InStr(1, vPara(i), "Name") > 0 Then 'This is the start of the required section
                rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
                rCount = rCount + 1

                xlSheet.Range("A" & rCount) = Trim(Replace(vPara(i + 1))) 'Name
                xlSheet.Range("B" & rCount) = Trim(Replace(vPara(i + 3))) 'Address1
                xlSheet.Range("C" & rCount) = Trim(Replace(vPara(i + 5))) 'Address2
                xlSheet.Range("D" & rCount) = Trim(Replace(vPara(i + 7))) 'City,State,Zip
                xlSheet.Range("E" & rCount) = Trim(Replace(vPara(i + 9))) 'Email
                xlSheet.Range("F" & rCount) = Trim(Replace(vPara(i + 11))) 'Phone
                xlSheet.Range("G" & rCount) = Trim(Replace(vPara(i + 13))) 'Date           

                Exit For 'Stop looking for paragraphs

            End If

    Next i


    Graham Mayor - Word MVP
    www.gmayor.com


    Saturday, May 04, 2013 7:26 AM
  • I'm getting a compile error... variable not defined. And the first line is highlighted (Sub CopyToExcel()  ). I have the references to Excel in place, so I don't know what I'm doing wrong. Everything is below, if you can spot my problem.

    Option Explicit

    Sub CopyToExcel()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "F:\Meg's Z Drive\UCDFD Stuff\SRFF\Interest Cards.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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
        rCount = rCount + 1

        'Check each line of text in the message body
        For i = 0 To UBound(vPara)
            If InStr(1, vPara(i), "Name") > 0 Then 'This is the start of the required section
                rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
                rCount = rCount + 1

                xlSheet.Range("A" & rCount) = Trim(Replace(vPara(i + 1))) 'Name
                xlSheet.Range("B" & rCount) = Trim(Replace(vPara(i + 3))) 'Address1
                xlSheet.Range("C" & rCount) = Trim(Replace(vPara(i + 5))) 'Address2
                xlSheet.Range("D" & rCount) = Trim(Replace(vPara(i + 7))) 'City,State,Zip
                xlSheet.Range("E" & rCount) = Trim(Replace(vPara(i + 9))) 'Email
                xlSheet.Range("F" & rCount) = Trim(Replace(vPara(i + 11))) 'Phone
                xlSheet.Range("G" & rCount) = Trim(Replace(vPara(i + 13))) 'Date

                Exit For 'Stop looking for paragraphs
            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, May 06, 2013 10:07 PM
  • The following version uses late binding so doesn't need the reference to Excel. It will need the references to Visual Basic for Applications and Outlook, but I think they should be checked by default.

    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim olItem As MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "F:\Meg's Z Drive\UCDFD Stuff\SRFF\Interest Cards.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))

            'Check each line of text in the message body
            For i = 0 To UBound(vPara)
                If InStr(1, vPara(i), "Name") > 0 Then        'This is the start of the required section
                    'Find the next empty line of the worksheet
                    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
                    rCount = rCount + 1

                    xlSheet.Range("A" & rCount) = Trim(Replace(vPara(i + 1)))        'Name
                    xlSheet.Range("B" & rCount) = Trim(Replace(vPara(i + 3)))        'Address1
                    xlSheet.Range("C" & rCount) = Trim(Replace(vPara(i + 5)))        'Address2
                    xlSheet.Range("D" & rCount) = Trim(Replace(vPara(i + 7)))        'City,State,Zip
                    xlSheet.Range("E" & rCount) = Trim(Replace(vPara(i + 9)))        'Email
                    xlSheet.Range("F" & rCount) = Trim(Replace(vPara(i + 11)))        'Phone
                    xlSheet.Range("G" & rCount) = Trim(Replace(vPara(i + 13)))        'Date

                    Exit For        'Stop looking for paragraphs
                End If
            Next i
            xlWB.Save
        Next olItem
        xlWB.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = Nothing
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, May 07, 2013 4:43 AM
  • Thank you for that!

    I'm still getting a compile error, but this one's different! Now it says, "argument not optional," and it seems to be hanging up on the "replace" command. Wish I knew what I was doing!

    Friday, May 10, 2013 2:09 AM
  • This worked perfectly form me.. thank you so much.  I was wondering though, is it possible to have it search for all emails that match a specific subject .. and then perform the copy to excel function on all of those emails in one shot?  Thank you.
    Monday, May 20, 2013 11:55 PM
  • You would need to add a condition after the line

    For Each olItem In Application.ActiveExplorer.Selection

    ie

    If Lcase(olItem.Subject) = "lower case text to search for" then

    and close the condition before

    Next olItem

    i.e.

    End If
    Next olItem

    Select all the messages and run the macro.


    Graham Mayor - Word MVP
    www.gmayor.com


    Tuesday, May 21, 2013 4:51 AM
  • This code below really works well for me, the only thing I need it to do is check every new incoming emails in a specific sub-folder and extract those data and the macro should run on start-up of outlook and stay on constantly. for some reason this code only extract the data of the email of looking at and I need to manually run the macro every time I want to extract the body messages.

    thank you for the help! :)

    Option Explicit

    Sub CopyToExcel()
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim oRng As Range
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\snguyen\Desktop\outage.xls" '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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
        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), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If

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

            If InStr(1, vText(i), "Services Affected:") > 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))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If

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

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

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

            If InStr(1, vText(i), "Ticket:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & 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

    Thursday, May 23, 2013 8:51 PM
  • You need to get rid of the loop and then run the macro as a script from a rule that identifies the appropriate incoming message for it to work automatically. You could change the Excel references to late binding while you are about it, and remove the redundant reference to oRng. The modifications are

    Option Explicit

    Sub CopyToExcel(olItem As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    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:\Users\snguyen\Desktop\outage.xls"        'the path of the workbook

        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 record
        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
        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), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If

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

            If InStr(1, vText(i), "Services Affected:") > 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))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If

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

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

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

            If InStr(1, vText(i), "Ticket:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Close 1
        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

    Friday, May 24, 2013 6:28 AM
  • This version of the macro is intended to be run from a rule. You cannot run it as a stand alone macro. It requires to know which message you want to process (olitem).

    That message will be the incoming message. Create a rule that identifies the message you wish to process e.g. by subject and select the option to run a script. Pick the macro as the script. Then as messages arrive that fit the criteria they are processed by the macro.


    Graham Mayor - Word MVP
    www.gmayor.com

    • Proposed as answer by sonny089 Friday, May 24, 2013 4:23 PM
    Friday, May 24, 2013 1:30 PM
  • I'm new to VB. I tried your code, but for some reason every time I tried to run the code it just pop up the macro windows. and can you tell me how would I reference a sub folder? and it how would I incorporate the "application startup()" to allow it automatically run the macro as outlook open. I assume that's what application startup() do?

    I really like how this code below works.  it would run in the background always and detect any new emails and put it into a spreadsheet, but it does not check through the body messages for certain words and then put the body messages into columns like the code above

    I appreciate your help a lot, thank you!

    Option Explicit

    Public myXLApp As Excel.Application
    Private WithEvents myOlItems  As Outlook.Items

    Private Sub Application_Startup()
        Dim olApp As Outlook.Application
        Dim objNS As Outlook.NameSpace
          Set olApp = Outlook.Application
          Set objNS = olApp.GetNamespace("MAPI")
          Set myOlItems = objNS.GetDefaultFolder(olFolderInbox).Items
    End Sub

    Private Sub myOlItems_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler

        Dim msg As Outlook.MailItem

        Dim myXLWB As Excel.Workbook
        Dim StrBody As String
        Dim TotalRows As Long, i As Long
        Dim WorkbookPath As String

    WorkbookPath = "C:\users\snguyen\desktop\emails.xls" 'Location of sheet recording mails

    'Check new item is an e-mail:
    If TypeName(item) = "MailItem" Then
        Set msg = item

    'Open Excel:
        Set myXLApp = New Excel.Application
        Set myXLWB = myXLApp.Workbooks.Open(WorkbookPath)

    'Find end of sheet:
        TotalRows = myXLWB.Sheets(1).Range("A65536").End(xlUp).Row
        i = TotalRows + 1

    'Make entries:
        With myXLWB.Worksheets(1)
            .Cells(i, 1) = Format(msg.SentOn, "yyyy-MM-dd hh:mm:ss")
            .Cells(i, 2) = msg.SenderName
            .Cells(i, 3) = msg.To
            .Cells(i, 4) = msg.Subject
            .Cells(i, 5) = msg.Body
        End With

    'Close workbook
        myXLWB.Save
        myXLWB.Close
        myXLApp.Quit
    End If

    ProgramExit:
        Exit Sub
    ErrorHandler:
        MsgBox Err.Number & " - " & Err.Description
        Resume ProgramExit
    End Sub

    Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim dateFormat
        dateFormat = Format(Now, "yyyy-mm-dd H-mm")

    saveFolder = "C:\users\snguyen\desktop\save"
        For Each objAtt In itm.Attachments
            objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
            Set objAtt = Nothing
        Next
    End Sub

                            



    • Edited by sonny089 Friday, May 24, 2013 1:36 PM
    Friday, May 24, 2013 1:31 PM
  • omg it works! thank G!!!
    Friday, May 24, 2013 4:23 PM
  • is there a way to add the time stamp, sender name, to, subject to these line of codes?

    something similar like this?

    Cells(i, 1) = Format(msg.SentOn, "yyyy-MM-dd hh:mm:ss")
            .Cells(i, 2) = msg.SenderName
            .Cells(i, 3) = msg.To
            .Cells(i, 4) = msg.Subject
            .Cells(i, 5) = msg.Body

    Friday, May 24, 2013 4:26 PM
  • The message is olItem, so substitute olItem for msg

    Following from the previous code, the syntax would be similar to

    xlSheet.Range("A" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:sws")

    where A is the column and rCount is the active row.


    Graham Mayor - Word MVP
    www.gmayor.com

    Saturday, May 25, 2013 7:39 AM
  • Thanks it works, but one minor problem now.

    For some reasons it does not extract correct for this part of the code. For example Event Start Time: 17:50 EDT 

    It only extract this much "Event Start Time: 17". It seems like the colon is messing it up somehow. 
    anyway to work around this?


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

            If InStr(1, vText(i), "Event Stop Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & rCount) = Trim(vItem(1))
            End If
    Tuesday, May 28, 2013 4:14 PM
  • I think you will find that this is covered elsewhere in the thread.

    vItem = Split(vText(i), Chr(58))

    splits the string into segments separated at the colons and thus in your example Trim(vItem(1)) produces '17'


    If you want 17:50 EDT you would need to re-assemble the string thus

    xlSheet.Range("G" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))

    if you want just 17:50 then you would need

    xlSheet.Range("G" & rCount) = Trim(vItem(1)) & Chr(58) & Replace(Trim(vItem(2)), " EDT", "")


    Graham Mayor - Word MVP
    www.gmayor.com

    • Proposed as answer by sonny089 Thursday, May 30, 2013 3:12 PM
    • Unproposed as answer by sonny089 Thursday, May 30, 2013 3:12 PM
    Wednesday, May 29, 2013 5:03 AM
  • I used this line of codes xlSheet.Range("G" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2)), and it does not extract nothing at all.

    I kept getting a pop up about "outages.xls is already open. reopening will cause any changes you made to be discarded. do you want to reopen outages.xls?"

    here is the codes im using.

    Option Explicit

    Sub CopyToExcel(olItem As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    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:\Users\snguyen\Desktop\outages.xls"   'the path of the workbook

        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 record
        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
        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), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:sws")
            End If
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Format(olItem.SenderName)
            End If
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Format(olItem.To)
            End If
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Format(olItem.Subject)
            End If
            
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If

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

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

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

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

            If InStr(1, vText(i), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("J" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
            End If

            If InStr(1, vText(i), "Event Stop Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("K" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
            End If

            If InStr(1, vText(i), "Ticket:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("L" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub


    Wednesday, May 29, 2013 1:19 PM
  • If the macro crashes then the workbook remains open hence the error message. Press CTRL+SHIFT+ESC and you should see that Excel.exe is still running. Ensure that it is closed before testing further.

    The date string was based on the information you provided. If you want me to check the code you will have to make a message available -

    Can you post a copy of the message file somewhere e.g. dropbox or skydrive so that I may see it?


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, May 29, 2013 2:34 PM
  • I think these line of codes are causing the error

     If InStr(1, vText(i), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("J" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
            End If

            If InStr(1, vText(i), "Event Stop Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("K" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
            End If


    Here's two messages you can try out

    Event Notification For:  Rain fade

    Event Type: Outage Restored

    Services Affected: Transport

    Location: XXXXX

    Current Status: Rain fade service outage restored for the following transponders 

    Event Start Time: 1951 Hrs EDT

    Event Stop Time: 20:14 Hrs EDT

    Ticket: 36247766

    ------------------------------------------------------------------------------------------------------

    Event Notification For: Viasala (GDS)

    Event Type: Investigation

    Services Affected: Transport

    Location:  NLV

    Current Status: Currently investigating Vsat sites for Viasala (GDS) for high latency . Issue has been escalated to engineering.

    Event Start Time: 17:50 EDT

    Event Stop Time: Ticket: 36245080






    • Edited by sonny089 Wednesday, May 29, 2013 6:37 PM
    Wednesday, May 29, 2013 3:27 PM
  • Messages copied into the forum dialog do not necessarily accurately reflect the actual messages. For example, in the second example, the Event Stop Time value appears to be the following line value, and in the two examples the start time formats differ from one another. It is possible to error trap, but only if the range of errors is known.


    The code that extracts the data is

    vItem = Split(vText(i), Chr(58))

    This splits the text in the line in question into segments separated by the colons. The segments are numbered from 0.

    Event Start Time: 17:50 EDT

    vItem(0) = "Event Start Time"
    vItem(1) = " 17"
    vItem(2) = "
    50 EDT"

    However in the case of

    Event Start Time: 1951 Hrs EDT

    vItem(0) = "Event Start Time"
    vItem(1) = "  1951 Hrs EDT"
    vItem(2) = does not exist!

    because vItem(2) does not exist the macro errors out.

    You can trap the non-existence of vItem(2) as follows

    Declare another variable

    Dim strText as String

    then change the code to

            If InStr(1, vText(i), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
            End If
            xlSheet.Range("J" & rCount) = strText

    and make similar changes to Event Stop Time.

    This will not produce an error for

    Event Stop Time: Ticket: 36245080

    but neither will it produce the correct value, and the value for Ticket: will be wrong also. If the messages are going to be random in format there is no end to the permutations. You need to get whoever is sending them to address the errors.


    Graham Mayor - Word MVP
    www.gmayor.com

    • Proposed as answer by sonny089 Thursday, May 30, 2013 3:12 PM
    Thursday, May 30, 2013 7:56 AM
  • Everything is working perfectly the way I wanted now, but I have another question for you GMayor.

    Is possible every time the spread sheet is updated it will automatically send to the updated excel file to a group of emails?

    Below is the codes I am currently using at the moment, so what can I do to add that functionality? thanks!!!

    Option Explicit

    Sub CopyToExcel(olItem As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim strText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\snguyen\Desktop\outage.xls"        'the path of the workbook

        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 record
        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
        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), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:sws")
            End If
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Format(olItem.SenderName)
            End If
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Format(olItem.To)
            End If
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Format(olItem.Subject)
            End If
            
            
            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If

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

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

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

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

             If InStr(1, vText(i), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("J" & rCount) = strText
            End If
            

            If InStr(1, vText(i), "Event Stop Time:") > 0 Then
               vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("K" & rCount) = strText
            End If
            

            If InStr(1, vText(i), "Ticket:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("L" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub


    Thursday, May 30, 2013 3:07 PM
  • You need to create a new message as follows - to send the message to the address(es) which may not survive the forum but which are marked in bold. Note the bold text near the end of the macro also.

    Option Explicit

    Sub CopyToExcel(olItem As Outlook.MailItem)
    Dim olOutMail As Outlook.MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim strText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\snguyen\Desktop\outage.xls"        'the path of the workbook
    Const strAddr As String = "someone@somewhere.com; someone_else@somewhere.com"        ' the addresses) you want to send the message to
        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 record
        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
        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), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:sws")
            End If

            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Format(olItem.SenderName)
            End If

            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Format(olItem.To)
            End If

            If InStr(1, vText(i), "Event Notification For:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Format(olItem.Subject)
            End If


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

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

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

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

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

            If InStr(1, vText(i), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("J" & rCount) = strText
            End If


            If InStr(1, vText(i), "Event Stop Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("K" & rCount) = strText
            End If


            If InStr(1, vText(i), "Ticket:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("L" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        Set olOutMail = Application.CreateItem(0)
        With olOutMail
            .To = strAddr
            .Subject = "Updated worksheet"        'the subject of the message
            .Body = "Latest worksheet update"
            .Attachments.Add strPath
            .Display        'Change to .Send after testing
        End With
        Set olOutMail = Nothing
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Friday, May 31, 2013 12:33 PM
    • Proposed as answer by sonny089 Friday, May 31, 2013 1:57 PM
    Friday, May 31, 2013 12:31 PM
  • it works. Thank you for the help for the passed few days :)

    I learnt a lot, even though I wont be able to write a good codes like this, but thanks to you I understand how these codes works.

    Friday, May 31, 2013 2:05 PM
  • Hey Gmayor!

    How can I use the worksheetfunction.substitute to remove broken spaces for each output? I tried Trim but it doesnt remove the broken spaces.

      If InStr(1, vText(i), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = worksheetfunction.substitute(strText & Chr(58) & vItem(2))
                xlSheet.Range("J" & rCount) = strText
            End If

    Wednesday, June 05, 2013 6:14 PM
  • What do you mean by 'broken spaces'?

    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, June 06, 2013 5:24 AM
  • Non-breaking vs. Regular Spaces

    As mentioned, spaces are characters and each character has a number known as its ASCII code or value.

    ASCII stands for the American Standard Code for Information Interchange and it creates one set of codes for 255 characters and symbols for use in computer programs.

    The ASCII code for a non-breaking space is 160. The ASCII code for a regular space is 32.

    The TRIM function can only remove spaces that have an ASCII code of 32.

    =TRIM(SUBSTITUTE(D1,CHAR(160),CHAR(32)))

    "   17:50 HRS EDT"

    I have a question, for the part where it grabs the times. is it possible to to remove the COLON and the NON_BREAKING SPACES from the time so it will only be "1750" and is it possible to remove the HRS EDT too? I need it to be military time so I can convert it to this format "HH:MM AM/PM". Is it possible to have it extract the time and convert it into the format and have it store it in memory then have it display?

    Thursday, June 06, 2013 1:24 PM
  • I think that

        If InStr(1, vText(i), "Event Start Time:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            strText = vItem(1)
            If UBound(vItem) > 1 Then strText = strText & vItem(2)
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(strText, "HRS EDT", "")
            xlSheet.Range("J" & rCount) = Trim(strText)
        End If

    should do the trick


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, June 06, 2013 1:44 PM
  • it didnt work. any idea G?

    Event Notification For: Layer 2

    Event Type: Investigation Closed

    Services Affected: DSL

    Location: NLV

    Current Status: The HNMON alarms for NLV Layer2 DSL Sites have cleared before isolation.  However, will continue to monitor

    Event Start Time: 1110 Hrs EDT <<<it didn't pull this, it left a blank

    Event Stop Time: 1155 Hrs EDT  <<<it didn't pull this, it left a blank (use the same code just did minor editing)

    Ticket: 36461373

    Thursday, June 06, 2013 5:06 PM
  • Apologies - it should have read

    If InStr(1, vText(i), "Event Start Time:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            strText = vItem(1)
            If UBound(vItem) > 1 Then strText = strText & vItem(2)
    End If
    strText = Replace(strText, Chr(160), Chr(32))
    strText = Replace(strText, "HRS EDT", "")
    xlSheet.Range("J" & rCount) = Trim(strText)


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, June 07, 2013 11:44 AM
  • Same result, still pulling blanks only. I thought you might have miss an "end if" at the end, but it made an error for me when i tried it XD

    I'm not sure if I'm correct, but don't we need to use some kind of excel function like FIND or SEARCH the characters/text strings first before replacing it with a " "?

    here is a download link to a sample msg for you to test out.

    https://www.dropbox.com/s/a82xrp1onuyj0rn/sample%20msg%20for%20GMAYOR%20to%20test.msg

    Option Explicit
    
    Sub CopyToExcel(olItem As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim strText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\snguyen\Desktop\outages.xls"   'the path of the workbook
    
        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 record
        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
        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), "Sent: ") > 0 Then
               vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("B" & rCount) = Trim(strText)
            End If
    
                xlSheet.Range("C" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:ss")
    
                xlSheet.Range("D" & rCount) = Format(olItem.SenderName)
    
    
                xlSheet.Range("E" & rCount) = Format(olItem.To)
    
    
                xlSheet.Range("F" & rCount) = Format(olItem.Subject)
    
    
            If InStr(1, vText(i), "Event Notification For: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("G" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Event Type: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Services Affected: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Location: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("J" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Current Status: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("K" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
                End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(strText, "HRS EDT", "")
            xlSheet.Range("J" & rCount) = Trim(strText)
    
            If InStr(1, vText(i), "Event Stop Time: ") > 0 Then
               vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("M" & rCount) = Trim(strText)
            End If
    
    
            If InStr(1, vText(i), "Ticket: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("N" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub
    
                                                             



    • Edited by sonny089 Friday, June 07, 2013 1:32 PM trying to help gmayor
    Friday, June 07, 2013 12:55 PM
  • For this particular sample message the following section will work, but as I indicated earlier it will only work as long as the format remains reasonably consistent. VBA doesn't do guesswork. This one takes case out of the equation.

            If InStr(1, LCase(vText(i)), "event start time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("J" & rCount) = Trim(strText)

            If InStr(1, LCase(vText(i)), "event stop time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("M" & rCount) = Trim(strText)


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, June 07, 2013 2:05 PM
  • idk what to do, it doesn't work for me. For some reasons when I use the codes you just gave me. The results came out to be unexpected, it display the Sent on Date from the original messages. I can't think of anything to help you troubleshoot this issue. 

    How come this is in lower case?  

      If InStr(1, LCase(vText(i)), "event start time:") 

       If InStr(1, LCase(vText(i)), "event stop time:") 

    Do you need me to send you some sample messages?

    they are pretty consistent, the format usually like this

    00 : 15 EDT

    00 : 15 Hrs EDT

    0015 EDT

    0015 Hrs EDT

    currently using this code with the code you gave me to test out

    Option Explicit
    
    Sub CopyToExcel(olItem As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim strText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Const strPath As String = "C:\Users\snguyen\Desktop\outages.xls"   'the path of the workbook
    
        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 record
        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
        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), "Sent: ") > 0 Then
               vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("B" & rCount) = Trim(strText)
            End If
            
                xlSheet.Range("C" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:ss")
            
                xlSheet.Range("D" & rCount) = Format(olItem.SenderName)
            
        
                xlSheet.Range("E" & rCount) = Format(olItem.To)
    
            
            If InStr(1, vText(i), "Subject: ") > 0 Then
               vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("F" & rCount) = Trim(strText)
            End If
     
            
            If InStr(1, vText(i), "Event Notification For: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("G" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Event Type: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Services Affected: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Location: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("J" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Current Status: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("K" & rCount) = Trim(vItem(1))
            End If
    
             If InStr(1, LCase(vText(i)), "Event Start Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("L" & rCount) = Trim(strText)
    
            If InStr(1, LCase(vText(i)), "Event Stop Time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("M" & rCount) = Trim(strText)
            
    
            If InStr(1, vText(i), "Ticket: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("N" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub
    


    • Edited by sonny089 Monday, June 10, 2013 1:00 PM
    Monday, June 10, 2013 12:58 PM
  • It won't work if you change what I posted (which worked with the example message).

    Change the lines back to

    If InStr(1, LCase(vText(i)), "event start time:")
    and

    If InStr(1, LCase(vText(i)), "event stop time:")



    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, June 10, 2013 1:55 PM
  • I found out the problem, I can get the event time to show up correctly now. The problem is after removing the problem that cause it, cause a different problem.

    I removed those line and it fix the problem and the event times display correctly. Since i remove it the event times duplicate itself and display it in column B and F. As before having those lines include, the "Sent:" results column were duplicated in the event times columns.

     If InStr(1, vText(i), "Sent: ") > 0 Then
               vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("B" & rCount) = Trim(strText)
            End If
            
           
            
            If InStr(1, vText(i), "Subject: ") > 0 Then
               vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
                xlSheet.Range("F" & rCount) = Trim(strText)
            End If

    Tuesday, June 11, 2013 3:47 PM
  • You cannot keep changing things without knowing what you are doing and expect it to work correctly. I have made some changes so that it should work within the range of parameters that you sent.

    It will not work with messages that are not formatted correctly.

    DO NOT alter the case of the text strings.

    Nothing is written to column A or column B. The rest of the columns C to N are populated correctly from your test message.

    I have made some comments in the code.

    Sub CopyToExcel(olItem As Outlook.MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim strText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
        'Const strPath As String = "C:\Users\snguyen\Desktop\outages.xls"   'the path of the workbook

        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 record
        sText = olItem.Body
        vText = Split(sText, Chr(13))
        'Find the next empty line of the worksheet
        'The Column - here D - must not be an empty column
        rCount = xlSheet.Range("D" & xlSheet.Rows.Count).End(-4162).Row
        rCount = rCount + 1

        'Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1

            'There is no 'Sent: line in your sample message body, so this is superfluous
            'If InStr(1, vText(i), "Sent: ") > 0 Then
            '  vItem = Split(vText(i), Chr(58))
            '   strText = vItem(1)
            '   If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
            '   xlSheet.Range("B" & rCount) = Trim(strText)
            'End If

            xlSheet.Range("C" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:ss")
            xlSheet.Range("D" & rCount) = Format(olItem.SenderName)
            xlSheet.Range("E" & rCount) = Format(olItem.To)
            xlSheet.Range("F" & rCount) = Format(olItem.Subject)

            'There is no 'Subject: line in your sample message body, so this is superfluous
            'If InStr(1, vText(i), "Subject: ") > 0 Then
            '   vItem = Split(vText(i), Chr(58))
            '    strText = vItem(1)
            '    If UBound(vItem) > 1 Then strText = strText & Chr(58) & vItem(2)
            '    xlSheet.Range("F" & rCount) = Trim(strText)
            'End If


            'Convert the line to lower case then look for the lower case string
            If InStr(1, LCase(vText(i)), "event notification for:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("G" & rCount) = Trim(vItem(1))
            End If

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

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

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

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

            If InStr(1, LCase(vText(i)), "event start time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("L" & rCount) = Trim(strText)

            If InStr(1, LCase(vText(i)), "event stop time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("M" & rCount) = Trim(strText)


            If InStr(1, LCase(vText(i)), "ticket: ") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("N" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Close 1
        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

    Wednesday, June 12, 2013 5:19 AM
  • sorry! I forgot to mention there is no sent and subject line because those only there when I forward myself the emails I want to put into the spreadsheets for now since it is not working to how i want it, so I want to manually monitor each email that gets into the spreadsheet, so i forward the emails to myself. SO I had to use the Sent and Subject line to pull the original date of that message that was sent to me and I was did like to remove the "FW:" from the subject so I had to do it like this for now.

    I will test the code out now and let you know. I appreciate the help G!

    ...Ok I tried the code, the only problem with it is it duplicate the event start time and put in the event stop time.

    I do not how to say this, it seems like the strText is shared/public thus the event stop time use event start time strText and display it.


         If InStr(1, LCase(vText(i)), "event start time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("L" & rCount) = Trim(strText)

            If InStr(1, LCase(vText(i)), "event stop time:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                strText = vItem(1)
                If UBound(vItem) > 1 Then strText = strText & vItem(2)
            End If
            strText = Replace(strText, Chr(160), Chr(32))
            strText = Replace(UCase(strText), "HRS", "")
            strText = Replace(UCase(strText), "EDT", "")
            xlSheet.Range("M" & rCount) = Trim(strText)

    this probably taking to much of your time, we can stop working this part. I can just apply some formula on the spreadsheet itself to automate to extract the time like this 

    =LEFT(TRIM(SUBSTITUTE(L496,CHAR(160),CHAR(32))),5)

    the only problem is the colon, maybe i can do a a match/search from the colon then from left 2 and right 2 and combine. or can we remove the colon through the VB script?

    Is it possible to have the SentOn to be format in Date & Time Value in excel? because you cannot sort it since it is in text format when it is put into the spreadsheet.

    xlSheet.Range("C" & rCount) = Format(olItem.SentOn, "yyyy-MM-dd hh:mm:ss")



    • Edited by sonny089 Thursday, June 13, 2013 8:56 PM
    Thursday, June 13, 2013 8:02 PM
  • Hello,

    I saw your code. I tried applying it however it doesn't appear to be working or at least exporting any of the necessary information to the excel spreadsheet. Can you please advise. 

    Monday, August 26, 2013 8:27 PM
  • Hi,

    I am really new to VBA and am trying to get this code working for me without any success...

    wondering if you could please help me.

    here is the email format:

    New kcODSRegistration Details

    Submitted: 2/10/2013 11:02:36 AM

    First Name :

    Joe

    Last Name :

    Blogs

    Company Name :

    Joe Blogs & Co

    Contact Number :

    0412 123 123

    Contact Email :

    joe.blogs@hotmail.com

    Address :

    123 Princes Highway Traralgon Victoria

    Post Code :

    3844

    Your Account Code :

    1795

    This is the Code i am trying to use:

    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:\Users\joe.blogs\Desktop\outlook.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), "First Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Last Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Company Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Contact Number:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Contact Email:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("F" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Address:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("G" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Post Code:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("H" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Your Account Code:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("I" & 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


    any help would be greatly appreciated.

    regards 


    Wednesday, October 02, 2013 3:10 AM
  • The reason it doesn't work is that the strings are never found, because your sample e-mail format has spaces before the colons and your code doesn't.

    Thus

    If InStr(1, vText(i), "First Name:") > 0 Then

    should be

      If InStr(1, vText(i), "First Name :") > 0 Then

    etc. If in doubt copy and paste from a message.

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

    does not appear to reflect any line in your example macro?


    Graham Mayor - Word MVP
    www.gmayor.com


    Wednesday, October 02, 2013 5:08 AM
  • Hi Graham,

    Thank you very much for your help.

    The below was an error and should never have been there.

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

    I have added the spaces between the colons and the code is working perfectly.

    Thanks Again

    Andy

    Thursday, October 03, 2013 4:22 AM
  • Hi Graham,

    I am wondering if you can please help me again.

    I am wanting to do something very similar but this time the data in the body of my email is in a table.

    I have the below code which work perfectly except the data i am copying contains mobile phone numbers that begin with 0's, so when it pastes into excel the 0's are dropped of the front of the mobile phone numbers. Can you please help me with the correct syntax to paste values so it wont drop the 0's?

    Sub dd()
    Dim item As MailItem, x%
    Dim r As Object  'As Word.Range
    Dim doc As Object 'As Word.Document
    Dim xlApp As Object, wkb As Object
    Set xlApp = CreateObject("Excel.Application")
    Set wkb = xlApp.Workbooks.Add
    xlApp.Visible = True
    
    Dim wks As Object
    Set wks = wkb.Sheets(1)
    
    For Each item In Application.ActiveExplorer.Selection
    Set doc = item.GetInspector.WordEditor
        For x = 1 To doc.tables.Count
         Set r = doc.tables(x)
            r.Range.copy
           wks.Paste
           wks.Cells(wks.Rows.Count, 1).End(3).Offset(1).Select
        Next
    Next
    End Sub
    

    Regards

    Andy

    Friday, October 04, 2013 5:17 AM
  • Hey Graham,

    I'm the original poster, so first let me apologize for opening Pandora's box :)

    Second, thank you for your assistance with each of these issues :)

    Finally, I recently purchased a new laptop with Windows 7 and tried to copy&paste the original code to the developer in my Outlook 2010. However, I'm getting the following error:

    "Compile error:

    User-defined type not defined"

    Along with this, the first line of the module is highlighted yellow and the second line highlighted as if selected. Those lines are:

    Sub CopyToExcel()
     Dim xlApp As Excel.Application

    Looking forward to your assistance with this as well :)

    -golions


    WJM

    Tuesday, October 15, 2013 5:28 PM
  • Hi Andy.  I don't know much about macro's but excel automatically drops leading zeroes. The answer is to either enclose the values in quotes. Which would make the string example something like "07707123456". This can be achieved using this "chr(34) & mobile number field & chr(34)" in your code.  I think.

    OR you can fix it manually. See screen shot with Before and After (column A and B)

    Open the spreadsheet, select the column with phone number and right click.
    In the context menu, select 'Format Cells'
    In the window that pops open, click on "Custom" in the left pane
    In the right pane, over type the default word of 'General' with 0's (zeroes). The number of zeroes will be the length of the telephone number. usually 11.
    Then when that is done, save the file in .text or .csv format!
    It will still remove the zeroes if the files is opened again in Excel so it might be better to encase in quotes?

    Sorry it's not the perfect answer, but I hope it is helpful.

    with and without formatting. Column B has the formatting.



    Rob

    Tuesday, October 15, 2013 6:13 PM
  • Is Excel installed Golions?

    Also, check if there is additional invisible characters pasted with the code. Sometimes when selecting text, the selection tries to be clever and includes some characters which are normally are invisible. Such as carriage returns. I would copy then paste into notepad, then copy and paste from there to make sure formatting and other things are not getting in.

    Hope this is helpful.


    Rob

    Tuesday, October 15, 2013 6:20 PM
  • You certainly did open Pandora's box!

    The particular version of the code that you are using has early binding to Excel, which means that you must set a reference to Excel in Outlook VBA Tools References, or Outlook will not know what to do with xlApp.

    My message Wednesday, June 12, 2013 5:19 AM shows how to configure with late binding to Excel, which does not have the requirement to set the reference.


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, October 16, 2013 5:30 AM
  • That was helpful... always seems to be a simple overlooked step once you get passed the impossible VBA coding :)

    My next question relates to a different format but is generally the same. I would like to take the yellow highlighted items from the emails below and apply them as column headers. Then, I need the blue highlighted items to fall in below each of their respective columns.

     

    Hello John Doe,

     L111000 is yours!   You have accepted the Direct to Carrier Load ID: L111000 for ACME CO (FL   ONLY) requested by Awesome Co.
     
      What’s next?
      This load will appear in the “My Dispatched Loads” section of your dashboard   where you will have access to download the transport documents and update   load status to keep the shipper informed.

    Direct to Carrier Load Details:

                                                                                                                                                          
       

    Load ID:

       
       

    L111000

       
       

    Origin:

       
       

    Miami,     FL 33169

       
       

    Destination:

       
       

    Sanford,     FL 32771

       
       

    Scheduled Pick-Up:

       
       

    11/7/2013

       
       

    Scheduled Drop-Off:

       
       

    11/11/2013

       
       

    Terms:

       
       

    Check

       
       

    Submit Invoice to:

       
       

    Awesome     Co.

       
       

    Offer Price:

       
       

    $180.00

       
       

    Number of Vehicles:

       
       

    1

       
       

    VIN:

       
       

    YMM:

       
       

    1AAAAA11111100000

       
       

    2010     Cadillac CTS

       

    To contact the shipper for any questions related to this   load, see the attached Transport Order for more information.
     
      Is this a common route for you? Create a saved search for this route and the   next time a new load is posted to ACO that matches your saved criteria, you   will get instant email notifications with the load details.
     
      Click here to login now.

    ACO

    Awesome is our motto

    The only odd portion is the final two fields on the table are aligned horizontally vs. vertically, and I'm not sure if this will cause any issues.

    Thanks!!


    WJM

    Wednesday, November 06, 2013 9:18 PM
  • Beyond this, I am also interested in finding out whether or not a code can be written that will parse this information to a spreadsheet on SkyDrive.

    If this is not possible, then I will simply copy & paste from Excel :)


    WJM

    Wednesday, November 06, 2013 10:07 PM
  • The following will create a matching workbook if not present and will extract the data from the message AS YOU HAVE POSTED IT!

    Because the data is in tabular form, as you read through the lines of text, each cell of a table is treated as a separate line of text. In the example you provided, the values in the right column are three lines after the line with the value in the first column, so it is a simple matter to add the number of lines to the current line to get the required value e.g.

    If InStr(vText(i), "Load ID:") > 0 Then
           .Range("A" & iNextRow) = Trim(vText(i + 3))
    End If

    The last two items VIN and YMM have the values six lines apart from the headings, so you need to add 6 lines. The following work as long as the actual messages match what you have posted, otherwise you will have to adjust the numbers 3 and 6 accordingly. Change the path and filename as required.

    Option Explicit

    Sub ExtractMessageText()
    Dim olItem As MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText() As String
    Dim sText As String, sNewText As String
    Dim i As Long
    Dim iNextRow As Long
    Dim strWorkbookPath As String
    Dim strWorkbook As String
    Dim bXLStarted As Boolean

        strWorkbookPath = "C:\Path\"
        strWorkbook = strWorkbookPath & "Load_Data.xlsx"

        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        'Open the workbook to input the data
        If Not FileExists(strWorkbook) Then
            Set xlWB = xlApp.Workbooks.Add
            With xlWB.sheets(1)
                .Range("A1") = "Load ID"
                .Range("B1") = "Origin"
                .Range("C1") = "Destination"
                .Range("D1") = "Scheduled Pick-Up"
                .Range("E1") = "Scheduled Drop-Off"
                .Range("F1") = "Terms"
                .Range("G1") = "Submit Invoice To"
                .Range("H1") = "Offer Price"
                .Range("I1") = "Number of Vehicles"
                .Range("J1") = "VIN"
                .Range("K1") = "YMM"
            End With
            xlWB.SaveAs strWorkbook
        Else
            Set xlWB = xlApp.Workbooks.Open(strWorkbook)
        End If
        Set xlSheet = xlWB.sheets("Sheet1")

    Start:
        iNextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
        Set olItem = Application.ActiveExplorer.Selection.Item(1)
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            With xlSheet
                If InStr(vText(i), "Load ID:") > 0 Then
                    .Range("A" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Origin:") > 0 Then
                    .Range("B" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Destination:") > 0 Then
                    .Range("C" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                    .Range("D" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                    .Range("E" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Terms:") > 0 Then
                    .Range("F" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Submit Invoice to:") > 0 Then
                    .Range("G" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Offer Price:") > 0 Then
                    .Range("H" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "Number of Vehicles:") > 0 Then
                    .Range("I" & iNextRow) = Trim(vText(i + 3))
                End If
                If InStr(vText(i), "VIN:") > 0 Then
                    .Range("J" & iNextRow) = Trim(vText(i + 6))
                End If
                If InStr(vText(i), "YMM:") > 0 Then
                    .Range("K" & iNextRow) = Trim(vText(i + 6))
                End If
                With .Range("A" & iNextRow & ":K" & iNextRow)
                    .HorizontalAlignment = -4131
                    .VerticalAlignment = -4160
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = -5002
                    .MergeCells = False
                    .ColumnWidth = 16
                End With
            End With
        Next i
        xlWB.Close 1
        If bXLStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = 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

    Thursday, November 07, 2013 9:54 AM
  • I don't use SkyDrive or any online resource to store personal data. The NSA can read your stuff easily enough without handing it to them.

    I guess as long as the path is correct - strWorkbookPath - it should be OK


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, November 07, 2013 9:58 AM
  • My previous post is not showing the table properly. It really looks more like this:

    Load ID:

    L123456

    Origin:

    DELRAY BEACH, FL 33483

    Destination:

    Sanford, FL 32771

    Scheduled Pick-Up:

    11/8/2013

    Scheduled Drop-Off:

    11/11/2013

    Terms:

    Check

    Submit Invoice to:

    Cool Dudes Inc

    Offer Price:

    $155.00

    Number of Vehicles:

    1

    VIN:

    YMM:

    11111222223333344

    2010 Cadillac CTS


    WJM


    • Edited by patllc Thursday, November 07, 2013 4:36 PM
    Thursday, November 07, 2013 4:29 PM
  • As I said earlier you have to adjust 3 & 6 to reflect the line breaks between the wanted items. The revised sample appears to be 2 & 4, but you can test with

    Sub Test()
    Dim olItem As MailItem
    Dim sText As String
    Dim vText As Variant
    Dim i As Long
        Set olItem = Application.ActiveExplorer.Selection.Item(1)
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            If InStr(vText(i), "Load ID:") > 0 Then
                MsgBox vText(i) & vbCr & _
                       "+1 = " & vText(i + 1) & vbCr & _
                       "+2 = " & vText(i + 2) & vbCr & _
                       "+3 = " & vText(i + 3) & vbCr
            End If
            If InStr(vText(i), "VIN:") > 0 Then
                MsgBox vText(i) & vbCr & _
                       "+2 = " & vText(i + 2) & vbCr & _
                       "+3 = " & vText(i + 3) & vbCr & _
                       "+4 = " & vText(i + 4) & vbCr & _
                       "+5 = " & vText(i + 5) & vbCr & _
                       "+6 = " & vText(i + 6) & vbCr
            End If
        Next i
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, November 08, 2013 5:47 AM
  • I figured out that it's the "+1" option after I looked at the table in the email. The problem I'm having though is that it doesn't pull the text out of the email when I run it against groups of emails. And, it doesn't drop the info into columns where A1 = Load ID and new info is simply the Load ID number. It is actually not taking Load ID at all. Here are the changes I made:

    Option Explicit
    Sub ExtractMessageText()
    Dim olItem As MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText() As String
    Dim sText As String, sNewText As String
    Dim i As Long
    Dim iNextRow As Long
    Dim strWorkbookPath As String
    Dim strWorkbook As String
    Dim bXLStarted As Boolean
        strWorkbookPath = "C:PATH\"
        strWorkbook = strWorkbookPath & "BOOK.xlsx"

        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        'Open the workbook to input the data
        If Not FileExists(strWorkbook) Then
            Set xlWB = xlApp.Workbooks.Add
            With xlWB.Sheets("New")
                .Range("A1") = "Load ID"
                .Range("B1") = "Origin"
                .Range("C1") = "Destination"
                .Range("D1") = "Scheduled Pick-Up"
                .Range("E1") = "Scheduled Drop-Off"
                .Range("F1") = "Terms"
                .Range("G1") = "Submit Invoice To"
                .Range("H1") = "Offer Price"
                .Range("I1") = "Number of Vehicles"
                .Range("J1") = "VIN"
                .Range("K1") = "YMM"
            End With
            xlWB.SaveAs strWorkbook
        Else
            Set xlWB = xlApp.Workbooks.Open(strWorkbook)
        End If
        Set xlSheet = xlWB.Sheets("New")

    Start:
        iNextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
        Set olItem = Application.ActiveExplorer.Selection.Item(1)
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            With xlSheet
                If InStr(vText(i), "Load ID:") > 0 Then
                    .Range("A" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Origin:") > 0 Then
                    .Range("B" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Destination:") > 0 Then
                    .Range("C" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                    .Range("D" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                    .Range("E" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Terms:") > 0 Then
                    .Range("F" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Submit Invoice to:") > 0 Then
                    .Range("G" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Offer Price:") > 0 Then
                    .Range("H" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Number of Vehicles:") > 0 Then
                    .Range("I" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "VIN:") > 0 Then
                    .Range("J" & iNextRow) = Trim(vText(i + 2))
                End If
                If InStr(vText(i), "YMM:") > 0 Then
                    .Range("K" & iNextRow) = Trim(vText(i + 2))
                End If
                With .Range("A" & iNextRow & ":K" & iNextRow)
                    .HorizontalAlignment = -4131
                    .VerticalAlignment = -4160
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = -5002
                    .MergeCells = False
                    .ColumnWidth = 16
                End With
            End With
        Next i
        xlWB.Close 1
        If bXLStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = 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

     

    Thanks :)


    WJM

    Friday, November 08, 2013 11:47 AM
  • The Test macro I posted earlier will identify which lines the values are on.

    The macro is programmed to process only the current record or the first record in a selection. i.e.

    Set olItem = Application.ActiveExplorer.Selection.Item(1)

    If you want it to process a selection of records then you would have to loop through the selection and increment NextRow each time.Some of the earlier examples in the thread demonstrate how to do that.

    The current macro will work best if used in conjunction with a rule to identify and process the messages as they arrive.

    Change the two lines

    Sub ExtractMessageText()
    Dim olItem As MailItem

    to

    Sub ExtractMessageText(olItem as Outlook.MailItem)

    and call it as a script from the rule.


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, November 08, 2013 12:31 PM
  • So, I'm trying to implement what you are suggesting, but I'm totally confused. Here's what I've got so far:

    Option Explicit
    Sub ExtractFromOutlook()
     Dim xlApp As Excel.Application
     Dim xlWB As Excel.Workbook
     Dim xlSheet As Excel.Worksheet
     Dim olItem As Outlook.MailItem
     Dim vText As Variant
     Dim sText As String
     Dim iNextRow As Long
     Dim vItem As Variant
     Dim oRng As Range
     Dim i As Long
     Dim rCount As Long
     Dim bXStarted As Boolean
     Const strPath As String = "C:\Users\WJM\Desktop\Ready Direct Dispatched.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
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        On Error GoTo 0
        'Open the workbook to input the data
        If Not FileExists(strPath) Then
            Set xlWB = xlApp.Workbooks.Add
            With xlWB.Sheets(1)
                .Range("A1") = "Load ID"
                .Range("B1") = "Origin"
                .Range("C1") = "Destination"
                .Range("D1") = "Scheduled Pick-Up"
                .Range("E1") = "Scheduled Drop-Off"
                .Range("F1") = "Terms"
                .Range("G1") = "Submit Invoice To"
                .Range("H1") = "Offer Price"
                .Range("I1") = "Number of Vehicles"
                .Range("J1") = "VIN"
                .Range("K1") = "YMM"
            End With

    Set xlWB = xlApp.Workbooks.Open("C:\Users\WJM\Desktop\Ready Direct Dispatched.xlsx")
    Set xlSheet = xlWB.Sheets("New")
    '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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
        rCount = rCount + 1
        'Check each line of text in the message body
    Start:
        iNextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
        Set olItem = Application.ActiveExplorer.Selection.Item(1)
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            With xlSheet
                If InStr(vText(i), "Load ID:") > 0 Then
                    .Range("A" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Origin:") > 0 Then
                    .Range("B" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Destination:") > 0 Then
                    .Range("C" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                    .Range("D" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                    .Range("E" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Terms:") > 0 Then
                    .Range("F" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Submit Invoice to:") > 0 Then
                    .Range("G" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Offer Price:") > 0 Then
                    .Range("H" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "Number of Vehicles:") > 0 Then
                    .Range("I" & iNextRow) = Trim(vText(i + 1))
                End If
                If InStr(vText(i), "VIN:") > 0 Then
                    .Range("J" & iNextRow) = Trim(vText(i + 2))
                End If
                If InStr(vText(i), "YMM:") > 0 Then
                    .Range("K" & iNextRow) = Trim(vText(i + 2))
                End If
                With .Range("A" & iNextRow & ":K" & iNextRow)
                    .HorizontalAlignment = -4131
                    .VerticalAlignment = -4160
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = -5002
                    .MergeCells = False
                    .ColumnWidth = 16
                End With
            End With
        Next i
        xlWB.Close 1
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = 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

     

    I'm getting an error message saying "For without Next" ???


    WJM

    Friday, November 08, 2013 1:45 PM
  • You are over complicating it. You only had to add the loop and remove the line   'Set olItem = Application.ActiveExplorer.Selection.Item(1)

    You have not closed the loop and you have changed the check for the Workbook, omitting the End If (and have changed the sheet name, but not created a sheet of that name) and you have also changed the declarations at the top of the add-in to early binding with respect to the Excel components.

    I have highlighted below what you should have added, and changed the path to reflect your preferred workbook/sheet. I will assume Trim(vText(i + 1)) is correct, you having established that using the Test macro.

    Sub ExtractMessageText()
    Dim olItem As MailItem
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText() As String
    Dim sText As String, sNewText As String
    Dim i As Long
    Dim iNextRow As Long
    Dim strWorkbookPath As String
    Dim strWorkbook As String
    Dim bXLStarted As Boolean

        strWorkbookPath = "C:\Users\WJM\Desktop\"
        strWorkbook = strWorkbookPath & "Ready Direct Dispatched.xlsx"

        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        'Open the workbook to input the data
        If Not FileExists(strWorkbook) Then
            Set xlWB = xlApp.Workbooks.Add
            With xlWB.Sheets(1)
                .Name = "New"
                .Range("A1") = "Load ID"
                .Range("B1") = "Origin"
                .Range("C1") = "Destination"
                .Range("D1") = "Scheduled Pick-Up"
                .Range("E1") = "Scheduled Drop-Off"
                .Range("F1") = "Terms"
                .Range("G1") = "Submit Invoice To"
                .Range("H1") = "Offer Price"
                .Range("I1") = "Number of Vehicles"
                .Range("J1") = "VIN"
                .Range("K1") = "YMM"
            End With
            xlWB.SaveAs strWorkbook
        Else
            Set xlWB = xlApp.Workbooks.Open(strWorkbook)
        End If
        Set xlSheet = xlWB.Sheets("New")

        For Each olItem In Application.ActiveExplorer.Selection
            iNextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1
            'Set olItem = Application.ActiveExplorer.Selection.Item(1)
            sText = Replace(olItem.Body, Chr(160), Chr(32))
            vText = Split(sText, Chr(13))
            For i = 0 To UBound(vText)
                With xlSheet
                    If InStr(vText(i), "Load ID:") > 0 Then
                        .Range("A" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Origin:") > 0 Then
                        .Range("B" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Destination:") > 0 Then
                        .Range("C" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                        .Range("D" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Scheduled Pick-Up:") > 0 Then
                        .Range("E" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Terms:") > 0 Then
                        .Range("F" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Submit Invoice to:") > 0 Then
                        .Range("G" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Offer Price:") > 0 Then
                        .Range("H" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "Number of Vehicles:") > 0 Then
                        .Range("I" & iNextRow) = Trim(vText(i + 1))
                    End If
                    If InStr(vText(i), "VIN:") > 0 Then
                        .Range("J" & iNextRow) = Trim(vText(i + 2))
                    End If
                    If InStr(vText(i), "YMM:") > 0 Then
                        .Range("K" & iNextRow) = Trim(vText(i + 2))
                    End If
                    With .Range("A" & iNextRow & ":K" & iNextRow)
                        .HorizontalAlignment = -4131
                        .VerticalAlignment = -4160
                        .WrapText = False
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = -5002
                        .MergeCells = False
                        .ColumnWidth = 16
                    End With
                End With
            Next i
        Next olItem
        xlWB.Close 1
        If bXLStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = 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

    Friday, November 08, 2013 3:23 PM
  • I really appreciate your help, and I've sent over an email on your site. Look forward to hearing back and sending aid :)

    Thanks!


    WJM

    Friday, November 08, 2013 5:02 PM
  • Hello

    After hours of searching the internet I’ve come across this incredibly useful thread, and I’m hoping you can help me too.  I’ve tried the code in the first post and it is successfully extracting the data I need into the specified columns of the worksheet, however I am selecting several emails and it is only looking at the first email I’ve selected. When I run the Macro I would like the data for each email to be extracted into the same worksheet, each email on a separate row.  I’m new to VBA and it’s quite likely that I have misunderstood something.  Here is what each email looks like:

    First name: bob

    Family name: jones

    Email address for contact: bob@blah.co.uk

    Nationality: Nigerian

    bob is interested in:

    Level of Study: Postgrad/Graduate

    Subject/course of interest: Social work

    And here is my code:

    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:\Users\user\Desktop\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), "First name:") > 0 Then

                 vItem = Split(vText(i), Chr(58))

                 xlSheet.Range("A" & rCount) = Trim(vItem(1))

             End If

            If InStr(1, vText(i), "Family name:") > 0 Then

                 vItem = Split(vText(i), Chr(58))

                 xlSheet.Range("B" & rCount) = Trim(vItem(1))

             End If

            If InStr(1, vText(i), "Email address for contact:") > 0 Then

                 vItem = Split(vText(i), Chr(58))

                 xlSheet.Range("C" & rCount) = Trim(vItem(1))

             End If

            If InStr(1, vText(i), "Nationality:") > 0 Then

                 vItem = Split(vText(i), Chr(58))

                 xlSheet.Range("D" & rCount) = Trim(vItem(1))

             End If

            If InStr(1, vText(i), "Level of Study:") > 0 Then

                 vItem = Split(vText(i), Chr(58))

                 xlSheet.Range("E" & rCount) = Trim(vItem(1))

             End If

            If InStr(1, vText(i), "Subject/course of interest:") > 0 Then

                 vItem = Split(vText(i), Chr(58))

                 xlSheet.Range("F" & 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

    Would be grateful for any help you can give! I have Microsoft Excel 2010 and Outlook 2010.

    Thanks!

    Monday, December 02, 2013 2:33 PM
  • Change the section

    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

    to

    rCount = xlSheet.UsedRange.Rows.Count
        For Each olItem In Application.ActiveExplorer.Selection
            sText = olItem.Body
            vText = Split(sText, Chr(13))
            'Find the next empty line of the worksheet
            rCount = rCount + 1

    and it should work


    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, December 02, 2013 3:27 PM
  • Thanks so much for this very useful information, Graham Mayor.  My situation is very similar--I need to export content from the body of Outlook 2010 emails to an Excel Spreadsheet.  My emails also have a series of fields set up in the same way as the original question.  I've used your code and made it work for my fields.

    However, I have a field that isn't up quite the same, so isn't working.  Most of my fields consist of a name and a colon, such as

    Last Name:  CONTENT

    However, I have one field where there's a line break after the field name, like this

    Details:
    CONTENT

    I haven't been able to export the data from my Detail field to my spreadsheet.  Here's that bit of code:

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

    I found out that Chr(10) and Chr(13) refer to line breaks, but haven't been able to add them to the code in any way that makes it work.  I'm new to VBA.

    Thanks again!

    Deanna Kate


    • Edited by DeannaKate Tuesday, December 03, 2013 9:57 PM
    Tuesday, December 03, 2013 9:21 PM
  • This is not the ideal place to cut your teeth on VBA :) but it does include some useful techniques.

    The macro splits the message by line then steps through each line  - vText(i) - where 'i' is the current line number.

    In your example the content you seek is not in line (i) but the following line (i + 1), or if there is an empty line between (i + 2). This line doesn't need to be split again as there is no text before the colon to omit, so change:

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

    to

    If InStr(1, vText(i), "Details:") > 0 Then
    xlSheet.Range("G" & rCount) = Trim(vText(i + 1))
    End If


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, December 04, 2013 5:36 AM
  • Thank you so much, that worked perfectly!  There is one further problem which I haven’t been able to resolve:

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

    The email addresses are appearing in the Excel cells as

    HYPERLINK "mailto

    instead of just displaying the email address.  What do I need to change to make this work? Thank you.

    Wednesday, December 04, 2013 11:22 AM
  • I covered this aspect in a parallel thread

    Add

    Dim sAddr as String
    Dim vAddr as Variant
    Dim j as Long

    with the declarations at the start and then change the quoted section to

            If InStr(1, vText(i), "Email address for contact:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                sAddr = ""
                For j = 1 To UBound(vItem)
                    sAddr = sAddr & vItem(j)
                Next j
                If InStr(1, UCase(sAddr), "HYPERLINK") > 0 Then
                    vAddr = Split(sAddr, Chr(34))
                    sAddr = vAddr(UBound(vAddr))
                End If
                xlSheet.Range("C" & rCount) = sAddr
            End If


    Graham Mayor - Word MVP
    www.gmayor.com



    Wednesday, December 04, 2013 12:17 PM
  • At the risk of prolonging this thread, I thought it worth mentioning an alternative approach which is considerably faster than the other method once the workbook has been created. This method uses ADO to communicate with the worksheet. It also includes code to create the worksheet if not present. All the following (which is based on hanniella's extraction requirement) goes in a single Outlook module.

    Option Explicit
    Private olItem As MailItem
    Private xlApp As Object
    Private xlWB As Object
    Private vText() As String
    Private vItem As Variant
    Private sText As String
    Private vAddr As Variant
    Private i As Long, j As Long, k As Long
    Private strWorkbook As String
    Private bXLStarted As Boolean
    Private strFirstName As String
    Private strFamilyName As String
    Private strEmail As String
    Private strNationality As String
    Private strLevel As String
    Private strCourse As String
    Private strValues As String
    Const strWorkbookPath As String = "D:\My Documents\Test\User Files\Test\"
    Const strSheet As String = "New"

    Private Sub ExtractMessageText()
        strWorkbook = strWorkbookPath & "Extracted Message Data.xlsx"

        On Error Resume Next
        'Open Excel
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        'Create the workbook if not present at the indicated location
        If Not FileExists(strWorkbook) Then
            Set xlWB = xlApp.Workbooks.Add
            With xlWB.sheets(1)
                .Name = strSheet
                .Range("A1") = "First Name"
                .Range("A1").ColumnWidth = 28
                .Range("A1").WrapText = False
                .Range("B1") = "Family Name"
                .Range("B1").ColumnWidth = 28
                .Range("B1").WrapText = False
                .Range("C1") = "Email Address"
                .Range("C1").ColumnWidth = 28
                .Range("C1").WrapText = False
                .Range("D1") = "Nationality"
                .Range("D1").ColumnWidth = 28
                .Range("D1").WrapText = False
                .Range("E1") = "Level of Study"
                .Range("E1").ColumnWidth = 28
                .Range("E1").WrapText = False
                .Range("F1") = "Course of Interest"
                .Range("F1").ColumnWidth = 28
                .Range("F1").WrapText = False

                With .Range("A1:F1")
                    .HorizontalAlignment = -4131
                    .VerticalAlignment = -4160
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = -5002
                    .MergeCells = False
                End With
            End With
            xlWB.SaveAs strWorkbook
            xlWB.Close 1
            If bXLStarted Then
                xlApp.Quit
            End If
            Set xlApp = Nothing
            Set xlWB = Nothing
        End If
        'Check each message in the selection
        For Each olItem In Application.ActiveExplorer.Selection
            sText = Replace(olItem.Body, Chr(160), Chr(32))
            vText = Split(sText, Chr(13))
            'Check each line of the message
            For i = 0 To UBound(vText)
                'and get the values required from those lines
                If InStr(1, vText(i), "First name:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strFirstName = Trim(vItem(1))
                End If

                If InStr(1, vText(i), "Family name:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strFamilyName = Trim(vItem(1))
                End If

                If InStr(1, vText(i), "Email address for contact:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strEmail = ""
                    For j = 1 To UBound(vItem)
                        strEmail = strEmail & vItem(j)
                    Next j
                    If InStr(1, UCase(strEmail), "HYPERLINK") > 0 Then
                        vAddr = Split(strEmail, Chr(34))
                        strEmail = vAddr(UBound(vAddr))
                    End If
                End If

                If InStr(1, vText(i), "Nationality:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strNationality = Trim(vItem(1))
                End If

                If InStr(1, vText(i), "Level of Study:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strLevel = Trim(vItem(1))
                End If

                If InStr(1, vText(i), "Subject/course of interest:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    strCourse = Trim(vItem(1))
                End If
            Next i
            'assign all the values to a string
            strValues = ""
            strValues = strValues & strFirstName & "', '"
            strValues = strValues & strFamilyName & "', '"
            strValues = strValues & strEmail & "', '"
            strValues = strValues & strNationality & "', '"
            strValues = strValues & strLevel & "', '"
            strValues = strValues & strCourse
            'Use the write to worksheet function to write the values to the worksheet
            WriteToWorksheet strWorkbook, strSheet, strValues
        Next olItem
        Set olItem = Nothing
    End Sub

    Private Function WriteToWorksheet(strWorkbook As String, _
                                     strRange As String, _
                                     strValues As String)
    Dim ConnectionString As String
    Dim strSQL As String
    Dim CN As Object
        ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                           "Data Source=" & strWorkbook & ";" & _
                           "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
        strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
        Set CN = CreateObject("ADODB.Connection")
        Call CN.Open(ConnectionString)
        Call CN.Execute(strSQL, , 1 Or 128)
        CN.Close
        Set CN = Nothing
    End Function

    Private 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

    Wednesday, December 04, 2013 1:47 PM
  • Thanks very much!  Works!

    Yes, definitely not the best place to cut teeth on VBA, but in my world of on the job self-training, the only place is here, now, trying to answer the question, "Can we make the database do X?"  Oh, how I long for an actual class where I could learn this step by step.  But I also enjoy the puzzle solving aspect of the endeavor, so I'm the person who gets the job and sticks with it until it gets done.

    Again, thank you!

    Wednesday, December 04, 2013 2:41 PM
  • Thank you so much for your help, it’s working perfectly now!

    Tuesday, December 10, 2013 1:20 PM
  • I have one more problem to solve, which I haven’t been able to resolve, and would be grateful for your help.

    One of the fields in my email comes in as

    Location: City, ST

    I'd like to split that in my excel spreadsheet into two columns. I've figured out how to split it (and get rid of the comma) once it's in Excel using the "Text to Columns" function. But it would be much more elegant to split it and get rid of the comma during the import, if possible.

    Currently, my code for that portion, which puts "City, ST" in column E, is

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

    I did figure out that with the following code, I could put the state into the next column, F, but column E still contained "City, ST" and I couldn't figure out how to get rid of ", ST" in E.

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

    Thanks much!

    DeannaKate

    • Edited by DeannaKate Thursday, December 12, 2013 7:13 PM
    Thursday, December 12, 2013 7:08 PM
  • You were almost right, however you created the second split in the wrong place

    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


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, December 13, 2013 5:44 AM
  • Wonderful!  It works.  Thank you so much! 
    Friday, December 13, 2013 2:33 PM
  • Graham,

    This thread has been very useful.  I was able to take the script for the module and modify it to meet the criteria for my emails...I want to tabulate votes:

    Sample email:

    Best_Dancer_Boys: Mike Delucie

    Best_Dancer_Girls: Breanna Pearson

    Best_Dressed_Boys: John Martone

    Best_Dressed_Girl: Karla Desimini

    Best_Laugh_Boys: Nick Guercio

    Best_Laugh_Girls: Valerie Odeh

    Biggest_Appetite_Boys: Peter Mangeon

    Biggest_Appetite_Girls: Gianna Rizzi

    Class_Clown_Boys: Brett Nofi

    Class_Clown_Girls: Tayla Cornelia

    Class_Flirt_Boys: Matt Perez

    Class_Flirt_Girls: Isabel Coffey

    Cutest_Couple: Brandon DeTemple & Catherine Candelario

    Friendliest_Boys: Dan Thangavelu

    Friendliest_Girls: Natalie Kitts

    Life_of_the_Party_Boys: Mark Marchino

    Life_of_the_Party_Girls: Alyssa Lopresti

    Most_Accademic_Boys: Daniel Thangavelu

    Most_Accademic_Girls: Eleni Kallinos

    Most_Artistic_Boys: Mike Paulino

    Most_Artistic_Girls: Eleni Kallinos

    Most_Athletic_Boys: Nick Soriano

    Most_Athletic_Girls: Rachel Gumowski

    Most_Caring_Boys: Daniel Thangavelu

    Most_Caring_Girls: Katelyn Matcovsky

    Most_Enthusiastic_Boys: Cody Mitchell

    Most_Enthusiastic_Girls: Aylin Bayraktar

    Most_Likely_to_Brighten_your_Day_Boys: Dan Thangevelu

    Most_Likely_to_Brighten_your_Day_Girls: Katelyn Matcovsky

    Most_Likely_to_be_President_Boys: Sameer Singh

    Most_Likely_to_be_President_Girls: Eleni Kallinos

    Most_Musical_Boys: Lucien Coppola

    Most_Musical_Girls: Rebecca Schinasi

    Most_Outgoing_Boys: Boys

    Most_Outgoing_Girls: Jackie Guerra

    Most_Sarcastic_Boys: Kevin Morris

    Most_Sarcastic_Girls: Jackie Guerra

    Most_School_Spirit_Boys: Mark Eckert

    Most_School_Spirit_Girls: Jenny Price

    Most_Unique_Boys: Will Rossi

    Most_Unique_Girls: Katelyn Matcovsky

    Most_likely_to_become_a_Millionair_Boys: Jason Khanija

    Most_likely_to_win_an_Grammy_Boys: Lucien Coppola

    Most_likely_to_win_an_Most_likely_to_become_a_Millionair_Girls: Brittany Keeler

    Most_likely_to_win_an_Most_likely_to_win_an_Oscar_Girls: Ali Senal

    Most_likely_to_win_an_Oscar_Boys: Lucien Coppola

    Most_likely_to_win_an_Oscar_Girls: Ali Senal

    Nicest_Eyes_Boys: Kyle Wahl

    Nicest_Eyes_Girls: Yasemin Altintas

    Nicest_Hair_Boys: Scott Geyer

    Nicest_Hair_Girls: Gabby Adamus

    Nicest_Smile_Boys: Matt Perez

    Nicest_Smile_Girls: Aylin Bayraktar

    StudentID: 000801490

    Teacher?s_pet_Boys: Hanlet Delgado

    Teacher?s_pet_Girls: Alyssa Pentaleri

    Worst_Case_of_Senioritis_Boys: Nick Guercio

    Worst_Case_of_Senioritis_Girls: Lauren Tavormina

    submit: submit

    ___________________________________________________________

    My code:

    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:\Users\RTruglio\Documents\VoteTest.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), "Best_Dancer_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("A" & rCount) = Trim(vItem(1))
             End If

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

             If InStr(1, vText(i), "Life_of_the_Party_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("Q" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Accademic_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("R" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Accademic_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("S" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Artistic_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("T" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Artistic_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("U" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Athletic_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("V" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Athletic_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("W" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Caring_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("X" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Caring_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("Y" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Enthusiastic_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("Z" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Enthusiastic_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AA" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Likely_to_Brighten_your_Day_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AB" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Likely_to_Brighten_your_Day_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AC" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Likely_to_be_President_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AD" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Likely_to_be_President_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AE" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Musical_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AF" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Musical_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AG" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Outgoing_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AH" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Outgoing_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AI" & rCount) = Trim(vItem(1))
             End If
            
              If InStr(1, vText(i), "Most_Sarcastic_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AJ" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Sarcastic_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AK" & rCount) = Trim(vItem(1))
             End If
            
              If InStr(1, vText(i), "Most_School_Spirit_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AL" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_School_Spirit_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AM" & rCount) = Trim(vItem(1))
             End If
            
              If InStr(1, vText(i), "Most_Unique_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AN" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_Unique_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AO" & rCount) = Trim(vItem(1))
             End If
            
              If InStr(1, vText(i), "Most_likely_to_become_a_Millionair_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AP" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_likely_to_win_an_Grammy_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AQ" & rCount) = Trim(vItem(1))
             End If
            
              If InStr(1, vText(i), "Most_likely_to_win_an_Most_likely_to_become_a_Millionair_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AR" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_likely_to_win_an_Most_likely_to_win_an_Oscar_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AS" & rCount) = Trim(vItem(1))
             End If
            
              If InStr(1, vText(i), "Most_likely_to_win_an_Oscar_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AT" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Most_likely_to_win_an_Oscar_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AU" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Nicest_Eyes_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AV" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Nicest_Eyes_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AW" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Nicest_Hair_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AX" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Nicest_Hair_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AY" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Nicest_Smile_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("AZ" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Nicest_Smile_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("BA" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "StudentID:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("BB" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Teacher?s_pet_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("BC" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Teacher?s_pet_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("BD" & rCount) = Trim(vItem(1))
             End If
            
              If InStr(1, vText(i), "Worst_Case_of_Senioritis_Boys:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("BE" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "Worst_Case_of_Senioritis_Girls:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("BF" & rCount) = Trim(vItem(1))
             End If
            
             If InStr(1, vText(i), "submit:") > 0 Then
                 vItem = Split(vText(i), Chr(58))
                 xlSheet.Range("BG" & 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

    _______________________________________________________________________________________________

    The Problem: 

    When I select multiple messages in Outlook and run the Macro.  I only have one row populated in the Excel spreadsheet.

    Can you help?

    Thank you,

    Rose

    Tuesday, December 17, 2013 5:13 PM
  • It should work, but you could move the line

    rCount = xlSheet.UsedRange.Rows.Count

    to before the loop starting

    For Each olItem In Application.ActiveExplorer.Selection


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, December 18, 2013 5:25 AM
  • I am having same requirement where i need to export data from outlook mail to Excel 1 mail 1 row in x-cel,

    My mail fromat is as bellow:

    +++++++++++++++++++++

    Alert Details

    Name....................RFC Logon failed

    Start Time..............03.01.2014 03:37:07 UTC

    End Time................03.01.2014 03:37:07 UTC

    Managed Object..........Sol Mgr Connections~CONN_MONIT~PSG00001~ABAP~SM_D7CCLNT300_TMW~RFC

    Managed Object Type.....Connection

    Rating..................Red

    Category................Configuration

    Status..................Open

    Alert Description

    This alert is generated if the logon for the underlying ABAP RFC destination fails. If the connection is generally available, check whether user is locked in target system or stored credentials are invalid.

    Link to Alert Inbox

    ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

    I am just interested in exporting fields : Name/Start Time/End Time/Managed Object/Managed Object Type/Rating/Category and Status

    Thanks & Best regards

    Manoj

    Friday, January 03, 2014 8:12 AM
  • The principle would be the same, except here you appear to have a series of periods between the description and the value. You cannot therefore split the lines at the colons. Instead you would need to process each line e.g.

            If InStr(1, vText(i), "Name...") > 0 Then
                strText = Replace(vText(i), "Name", "")
                strText = Replace(strText, ".", "")
                xlSheet.Range("A" & iNextRow) = strText
            End If

    With the times, which also use periods, you could use something like

          If InStr(1, vText(i), "Start Time") > 0 Then
                strText = Replace(vText(i), "Start Time..............", "")
                xlSheet.Range("B" & iNextRow) = strText
            End If

    assuming there is always the same number of characters.


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, January 03, 2014 1:58 PM
  • Thanks A Bunch Graham,

    I am able to get code compiled now , but getting Runtime Error '1004' , Application-Defined or object-defined error. I am not good in coding espcially VB.

    Looks like I messedup with the code , since there were so many code paste. The code I had after you suggested change is as bellow:

    +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

    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 strText As String
     Dim iNextRow As Long
     Dim i As Long
     Dim rCount As Long
     Dim bXStarted As Boolean
     Const strPath As String = "C:\Tech_Mon_Ana.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.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
         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), "Name....................") > 0 Then
                 strText = Replace(vText(i), "Name", "")
                 strText = Replace(strText, ".", "")
                 xlSheet.Range("A" & iNextRow) = strText
             End If
     
            If InStr(1, vText(i), "Start Time") > 0 Then
                 strText = Replace(vText(i), "Start Time..............", "")
                 xlSheet.Range("B" & iNextRow) = strText
            End If
     
            If InStr(1, vText(i), "End Time") > 0 Then
               strText = Replace(vText(i), "End Time................", "")
               xlSheet.Range("C" & iNextRow) = strText
            End If
     
            If InStr(1, vText(i), "Managed Object..........") > 0 Then
               strText = Replace(vText(i), "Managed Object", "")
               strText = Replace(strText, ".", "")
               xlSheet.Range("D" & iNextRow) = strText
            End If
     
            If InStr(1, vText(i), "Managed Object Type.....") > 0 Then
               strText = Replace(vText(i), "Managed Object Type", "")
               strText = Replace(strText, ".", "")
               xlSheet.Range("E" & iNextRow) = strText
            End If
     
            If InStr(1, vText(i), "Rating..................") > 0 Then
               strText = Replace(vText(i), "Rating", "")
               strText = Replace(strText, ".", "")
               xlSheet.Range("F" & iNextRow) = strText
            End If
     
            If InStr(1, vText(i), "Category................") > 0 Then
               strText = Replace(vText(i), "Category", "")
               strText = Replace(strText, ".", "")
               xlSheet.Range("G" & iNextRow) = strText
            End If
     
            If InStr(1, vText(i), "Status..................") > 0 Then
               strText = Replace(vText(i), "Status", "")
               strText = Replace(strText, ".", "")
               xlSheet.Range("H" & iNextRow) = strText
            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

    ++++++++++++++++++++++++++++++++++++++++++++++

    On debug it is pointing at line

    xlSheet.Range("H" & iNextRow) = strText

    Thanks once again..

    Manoj

     

    Saturday, January 04, 2014 6:47 AM
  • You have defined the row as rCount, but then called that row as iNextRow which is undefined - hence the error.

    Replace the lines

    rCount = xlSheet.UsedRange.Rows.Count
    rCount = rCount + 1

    with the one line (ignoring the break in the message format)

    iNextRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row + 1


    Graham Mayor - Word MVP
    www.gmayor.com



    Saturday, January 04, 2014 7:37 AM
  • Gr8, Thanks a ton, Graham,

    It worked perfect. Just 1 issue 1st (First) roe does come empty. and what is the meaning of .End(-4162) in the code you mentioned in earlier reply.

    Manoj

    Saturday, January 04, 2014 9:02 AM
  • The first row is for the header.

    -4162 is the numeric equivalent of xlUp which you cannot use here with Late Binding to the Excel object


    Graham Mayor - Word MVP
    www.gmayor.com

    Saturday, January 04, 2014 2:47 PM
  • Hi Graham,

    Is there any way to export the data which is in email but in tabular form for example

    Owner

    Database

    Table

    New Table

    New Columns

    New Grain To Existing Table

    New Values to Existing Column

    Rule Change to Existing Column

    Rakesh

    Products

    Driver

    N

    N

    N

    N

    Y

    It would be really helpful.

    Thursday, April 03, 2014 12:45 PM
  • A table in a message body behaves much as a set of paragraphs. Use the following macro to determine which lines you need in conjunction with the code posted in this thread.

    Sub TestLines()
    Dim olItem As Outlook.MailItem
    Dim vText() As String
    Dim sText As String
    Dim i As Long
        For Each olItem In Application.ActiveExplorer.Selection
            sText = Replace(olItem.Body, Chr(160), Chr(32))
            vText = Split(sText, Chr(13))
            For i = 0 To UBound(vText)
                MsgBox "Line " & i & vbCr & vText(i)
            Next i
        Next olItem
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, April 03, 2014 2:03 PM
  • hii all...

    can someone help me..?
    if The content comes in the following format:

    TT2222138

     

    Name = blablabla
    Vendor = blablabla
    Location: 128487 - blablabla
    Priority = blablabla

    Occured Time = 04/13/14 08:36:37
    Alarm Type                = blablabla
    Impact   = blablabla
    Action Handling        = blablabla
    ****

    ------------------------------------

    TT2222138 is Code Ticket, it must include on excell too...

    anyone get the VBA code for my content format..?? :)
    thx b4...

    Monday, April 14, 2014 4:51 AM
  • Use the test macro to get the line number of the 'Name =' line then count back to the Code Ticket line (which hopefully will always be the same number of lines away). Then instead of splitting the line as in the code examples, use the whole line.

    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, April 14, 2014 5:03 AM
  • Use the test macro to get the line number of the 'Name =' line then count back to the Code Ticket line (which hopefully will always be the same number of lines away). Then instead of splitting the line as in the code examples, use the whole line.

    sorry b4, can you type it for me..

    Monday, April 14, 2014 6:41 AM
  • Without the message it can only be approximate, but use the TestLines macro (in the message you responded to) to establish which line the name is on and which the number is on.

    The name is easier to locate so locate that then note the difference between that line number and the code ticket line, and subtract that number from the variable 'i' (below I have assumed 3) The following will thus put the code ticket in column A and the name in column B. The rest of the code can be established from the thread.

           If InStr(1, vText(i), "Name = ") > 0 Then
                xlSheet.Range("A" & rCount) = Trim(vText(i - 3) 'The number
                vItem = Split(vText(i), Chr(61))
                xlSheet.Range("B" & rCount) = Trim(vItem(1)) 'The name
            End If


    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, April 14, 2014 8:11 AM
  • Hi Graham,

    I am from Australia, and am an avid programmer/tinkerer....  I have no question to post however, I just wanted to say thank you for your thread replies above.  I have been working with MS Outlook (and exporting data) for some time and your thread replies have been very helpful.

    Take this as a message - THUMBS UP!

    Thanks Graham - keep up the excellent work. (others appreciate it more than you know).

    A.

    Sunday, May 04, 2014 4:29 AM
  • Thanks for those words of appreciation

    Graham Mayor - Word MVP
    www.gmayor.com

    Sunday, May 04, 2014 5:21 AM
  • Hello WJM(patllc),

    Your question above about asking the Macro to update a file located on SkyDrive is valid.  Yes it can be done.  Graham Mayor mentioned below;

    - strWorkbookPath -

    "I guess as long as the path is correct - Code Block above-  it should be OK"

    I am happy to update my own personal business data up at OneDrive (formerly SkyDrive) as it isn't too sensitive.  I do this successfully all the time but is dependent on a few variables as per below;

    Two thing to add here:

    1. The OneDrive you wish to update must be 'Your OneDrive' and accessible across a network (WWW) for it to work, and
    2. The OneDrive folder located on your own PC Windows Folder Tree (i.e. Windows Explorer), is what you should be referencing.... It is by far the simplest method I know.  You just use the OneDrive folder location on your PC as the correct path for the string in your code.

    Example;

    (from Technilee)

     'On the next line, edit the path to the workbook.  The path must end with a \.
        Const WORKBOOK_PATH = "C:\Users\User\SkyDrive\Documents\YourFolderLocation\"

    Hope this helps....


    • Edited by CadoGroupDev Sunday, May 04, 2014 6:17 AM Spelling
    Sunday, May 04, 2014 6:15 AM
  • A simple thing to remember about online storage, "Cloud" - if it's online, it's accessible by those suitably trained or learned from any online network from anywhere in the world.  Despite this, we have to accept to a certain degree, the risks associated with online storage.  Bearing this in mind, every single email ever sent in the world has already been stored somewhere, on some other server!

    Just be cautious.

    Sunday, May 04, 2014 6:20 AM
  • Thanks alot for your Help!!

    I would like to know if there is any option to limit to show only "OK" button instead of "Ok", "Cancel" and "New"

    while we are picking up from outlook.

    For example:

    Set myolitems1 = objNS.PickFolder

    I am unable to provide snapshot of the same, due to some restrictions.

    Thursday, May 08, 2014 6:58 AM
  • This is a built-in dialog box. There is no option to modify it that I can find documented. - http://msdn.microsoft.com/en-us/library/office/ff869969%28v=office.15%29.aspx

    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, May 08, 2014 9:00 AM
  • Hi, 

    I have a sample email content like this:


                            Name: nguyễn thị thu hương


    Email: thuhuong.633@gmail.com


    Mobile Phone: 0984779398


    Anmum Product: Materna Vanilla


    Address: số 45-ngõ 291 lạc long quân - hà nội


    DISCLAIMER
    This email contains information that is confidential and which may be legally privileged. If you have received this email in error, please notify the sender immediately and delete the email. This email is intended solely for the use of the intended recipient and you may not use or disclose this email in any way.

    So please help me to create script that can get the information about: Name, Email, Mobile Phone, Anmum Product, Address and then export them to excel file that located at C:\DATA\Request.xlsx

    Ps: I don't know anything about script so I could not make it by myself.

    Thursday, June 12, 2014 2:56 AM
  • Your requirement is no different from the examples already quoted in the thread. Use the parts before the colons to identify the lines to be processed and substitute those for examples in the code. If you wish me to do the work for you then contact me via my web site and we'll discuss it.

    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, June 12, 2014 5:57 AM
  • Hi Graham,

    I have successfully created my own script that help me export email content to excel file, BUT now, I need to export not only the email content but also the date time when the email arrived, what should I do? Could you give me an example script?

    I'll look forward to hearing from you. Thanks and best regards.

    Monday, June 16, 2014 3:50 AM
  • You could use:

    xlSheet.Range("A" & rCount) = Format(olItem.ReceivedTime, "dd/MM/yyyy") 'Date
    xlSheet.Range("B" & rCount) = Format(olItem.ReceivedTime, "hh:mm") 'Time

    where "A" and "B" are the Excel columns and change the date switch to local requirements.


    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, June 16, 2014 4:14 AM
  • Hi Graham,

    Where should I put the script above in my script? Under Set xlSheet = xlWB.Sheets("Sheet1") ?

    Here is my script:

    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:\DATA\AnmumVietnamRequest.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), "Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

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

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

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

            If InStr(1, vText(i), "Address:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & 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

    • Edited by Ricky Lý Monday, June 16, 2014 4:35 AM
    Monday, June 16, 2014 4:30 AM
  • Put it immediately after

    For Each olItem In Application.ActiveExplorer.Selection



    Graham Mayor - Word MVP
    www.gmayor.com

    Monday, June 16, 2014 5:03 AM
  • Hi Graham,

    I have edited my script as below:

    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:\DATA\AnmumVietnamRequest.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

    xlSheet.Range("F" & rCount) = Format(olItem.ReceivedTime, "dd/MM/yyyy") 'Date
    xlSheet.Range("G" & rCount) = Format(olItem.ReceivedTime, "hh:mm") 'Time
        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), "Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

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

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

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

            If InStr(1, vText(i), "Address:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & 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

    BUT when I select an email message and run this script (Alt + F8), the error banner shows up:

    Title: Microsoft Visual Basic

    Content: Run-time error '1004'

           Application-defined or object-defined error

    What should I do now? Waiting for your response :)


    Tuesday, June 17, 2014 2:51 AM
  • Apologies - I was forgetting about rCount which sets the row value

    Move the two lines to after the line

    rCount = rCount + 1


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, June 17, 2014 3:31 AM
  • Hi Graham,

    I really appreciate your help, my new script worked! BUT it exports the email content information to the wrong position in excel file (please see this image for further detail: https://dl.dropboxusercontent.com/u/60961203/wrongpositiondatetime.jpg

    Here is my new script: 

    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:\DATA\AnmumVietnamRequestwithDate.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
    rCount = rCount + 1
    xlSheet.Range("F" & rCount) = Format(olItem.ReceivedTime, "dd/MM/yyyy") 'Date
    xlSheet.Range("G" & rCount) = Format(olItem.ReceivedTime, "hh:mm") 'Time
        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), "Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

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

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

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

            If InStr(1, vText(i), "Address:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & 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

    Hope you can help me fix this issue soon, we almost finish this script :D

    Tuesday, June 17, 2014 4:44 AM
  • You didn't actually do what I said. You added another rcount line, which is not going to work. the lines should be inserted after the existing rCount definition. It is rCount that determines on which line of the worksheet the data is stored.

    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

    xlSheet.Range("F" & rCount) = Format(olItem.ReceivedTime, "dd/MM/yyyy") 'Date
    xlSheet.Range("G" & rCount) = Format(olItem.ReceivedTime, "hh:mm") 'Time

        'Check each line of text in the message body


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, June 17, 2014 9:42 AM
  • Hi Graham, 

    My script works fine now. 

    My heartfelt thanks to you.

    Wednesday, June 18, 2014 3:57 AM
  • Hi Graham, I tried your code to extract the data out of my email, adjusting for the names and running into issues... my data in the email is actually in table format preceded by a short introduction from the sender... i keep running into errors... is ther a way you can help me? i tried to attach the table but having trouble... its basically two columns, the first being the field name, the second being the data. what i tried to do was to take the field names and place the across the top of the worksheet and the corresponding data underneath.... i hope this helps.... Thank you in advance!!!

    Monday, June 23, 2014 3:59 PM
  • Use the macro - Sub TestLines() which you will find in this thread (use your browser search function to find it) to identify the 'lines' which contain the data that you wish to extract and use those lines in the extraction macro.

    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, June 24, 2014 4:56 AM
  • Thank you for your help! worked!
    Wednesday, June 25, 2014 6:17 PM
  • Dear Garham

    My question is about I am getting employee announcements emails in HTML table format  in Emp annocuments folder in outlook . there are three types of emails lands to me on daily basis

    1-Permanent Employee resignations

    2-Permanent Employee Change in status

    3-Third party change in status

    4-Third party Employee resignations

    Permanent Employee resignations (Example Email)

    Subject: Resignation - Garham Mayor - 1375

    Reason

    Resignation

    Resignation  Date

    01-Jul-2014

    Last Working Date

    31-Jul-2014

    Employee Name

    Mr Garham Mayor

    Employee Number

    55555

    Designation

    Assistant Manager Finance

    Job Group

    8B

    Department

    Sales & Distribution

    Division/Company

    Commercial

    Location

    London





    Official Number

    03XX-5559999

    Email Address

    garham.mayor@officedomain.com

    Change in status Emails Table on daily basis

    Subject: Change in Status - Garham Mayor (7878)

    New Status

    Change in Reporting Line

    Effective Date

    01-Jun-14

    Employee Name

    Garham Mayor

    Employee Code

    7878

    Designation

    Financial Operations Specialist

    Job Group

    8B

    Department

    Financial Control

    Unit

    Financial Operations

    Division

    Finance

    Location

    Mumbai

    Reporting Line

    Ricky Pointing

    can using above code tweaked so that I can extract all mails in to excel with the HTML Table data in excel sheet.

    this code is working for me but HTML export solution 7 not working

    http://techniclee.wordpress.com/2011/10/29/exporting-outlook-messages-to-excel/


    Wednesday, July 02, 2014 6:31 AM
  • Use your browser's search function to find the macro TestLines in this thread, and use that to establish which lines contain the parts of the message you wish to extract (including the table).

    In the case of the table, there will be no need to split the lines as the lines in the table will be the complete cell content.


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, July 02, 2014 6:45 AM
  • Graham, 

    I had the similar question. I followed as you said, and it is working; however it does not run the macro on all the messages i selected. If select 10 messages at once, it only does the last one. I only have 3 fields in my form, so I modified the code. Also, we need to gather all the data EVEN if some only filled out the from field and not message.

    My contact Form:

    Message:

    From:

    Phone:

    Code i am using for Macro:

    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:\users\jianna\My Documents\Emails.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), "Message:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

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

            If InStr(1, vText(i), "Phone:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & 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

    THANK YOU!

    Monday, July 14, 2014 7:16 PM
  • The reason it is not working and only includes the last message is that you have incremented the counter 'rCount' outside the loop. rCount + 1 should be after the line

    For i = UBound(vText) To 0 Step -1


    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, July 15, 2014 4:37 AM
  • Graham,

    Thank you for the information. I apologize i am a little confused. I input the following beneath the line and received a compilation error:

     For i = UBound(vText) To 0 Step -1
        rCount 1

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

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

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

    Should that rCount +1 be placed beneath that line?

    Tuesday, July 15, 2014 6:48 PM
  • You had originally

    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

    it should be

    rCount = xlSheet.UsedRange.Rows.Count

        'Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1

        rCount = rCount + 1


    Graham Mayor - Word MVP
    www.gmayor.com

    Wednesday, July 16, 2014 4:11 AM
  • As this thread appears to have taken a life of its own, I have added the salient points to an easier to follow web page - http://www.gmayor.com/extract_data_from_email.htm

    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, July 17, 2014 2:47 PM
  • I'm kind of a newbie at this but I did get the macro working. I have 1 important thing I need this to do though. Can I select multiple emails and run the macro? It keeps overwriting the same row.

    This is my code below

    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:\Users\adeboer\Desktop\360quiz.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), "Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Quiz:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If
    
            If InStr(1, vText(i), "Score:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & 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

    Monday, July 21, 2014 10:26 PM
  • You have the loop counter in the wrong place. I think this was probably related to an error in at least one of the code sets in this thread. I have corrected the original macro.

    See also http://www.gmayor.com/extract_data_from_email.htm

    It should be:

    rCount = xlSheet.UsedRange.Rows.Count 'Check each line of text in the message body For i = UBound(vText) To 0 Step -1

        rCount = rCount + 1
    


    Graham Mayor - Word MVP
    www.gmayor.com


    Tuesday, July 22, 2014 4:04 AM
  • Thanks Graham!
    Friday, July 25, 2014 8:11 PM