none
Exporting part of the data from email to excel RRS feed

  • Question

  • Hello,


    I recieve emails in the give format:

    *******************************************************************

         !System      : xxx      Programme: xxxx

         !Stückliste  : xxx

         !SG-Name     : xxx

         !Auftraggeber:  xxxx

         !Abnehmer    : xxxx

         !              xxxxx

         !GO-Release  : xxxx

         !Vorgangs-Nr.: xxxxx

         !Server      : xxxxx



    I would like part of the information to be exported to excel. As I'm a total VBA newbie I've found a macro that could help me and made some modifications to suit my needs:


    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:\maile.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
     
        'Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1
          rCount = rCount + 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), "!System      :") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If

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

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

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

            If InStr(1, vText(i), "!Vorgangs-Nr.:") > 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

    When i run macro, nothing happens, no error, no freeze/crash etc. Any ideas?

    Wednesday, August 20, 2014 11:46 AM

Answers

  • There are a few issues with this, which seems to have been cobbled from one of my earlier threads - see http://www.gmayor.com/extract_data_from_email.htm for a breakdown of how it works.

    In the case of your message format, the following should work

    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 strData As String
    Const strPath As String = "D:\maile.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
            Set xlApp = CreateObject("Excel.Application")
        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.Range("D" & xlSheet.Rows.Count).End(-4162).Row 'You need to select a column that will always have data - here D.
        For Each olItem In Application.ActiveExplorer.Selection
            rCount = rCount + 1 'This goes here not in the second loop
            sText = olItem.Body
            vText = Split(sText, Chr(13))
            'Find the next empty line of the worksheet

            'Check each line of text in the message body
            For i = 0 To UBound(vText) ' there is no real need in this case to process in reverse order
                strData = vText(i)
                strData = Replace(strData, Chr(160), Chr(32)) 'Replace any non-breaking spaces
                If Not Trim(strData) = vbNullString Then
                    'If InStr(1, vText(i), "Source:") > 0 Then 'There is no 'Source line in the sample
                    '    vItem = Split(vText(i), Chr(58))
                    '    xlSheet.Range("A" & rCount) = Trim(vItem(1))
                    'End If
                    If InStr(1, strData, "!System") > 0 Then
                        vItem = Split(strData, Chr(58))
                      'There are two separators in this line, so you need to address that e.g.                    xlSheet.Range("B" & rCount) = Trim(Replace(vItem(1), "Programme", ""))
                    End If
                    'as the search characters are unique you can limit the searches to the unique words.
                    If InStr(1, strData, "!Stückliste") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("C" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!Abnehmer") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("D" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!GO-Release") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("E" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!Vorgangs-Nr.") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("F" & rCount) = Trim(vItem(1))
                    End If
                End If
            Next i
            xlWB.Save
        Next olItem
        xlWB.Close SaveChanges:=True

        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 Peter Kania Thursday, August 21, 2014 12:18 PM
    Wednesday, August 20, 2014 1:03 PM

All replies

  • Did you step in to your code line by line?

    (push F8 in your code screen)

    • Marked as answer by Peter Kania Wednesday, August 20, 2014 12:30 PM
    • Unmarked as answer by Peter Kania Wednesday, August 20, 2014 12:30 PM
    Wednesday, August 20, 2014 12:03 PM
  • It crashes on line    MsgBox "No Items selected!", vbCritical, "Error".      with No items selected

    Ive deleted the line, no more error but still no effect when running macro
    is it normal that using F8 skips some  lines? Those sections werent highlighted:

    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:\maile.xlsx" 'the path of the workbook





     sText = olItem.Body
        vText = Split(sText, Chr(13))
        'Find the next empty line of the worksheet
       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
          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), "!System      :") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If

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

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

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

            If InStr(1, vText(i), "!Vorgangs-Nr.:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("F" & rCount) = Trim(vItem(1))
            End If
        Next i
        xlWB.Save
    Next olItem
    Wednesday, August 20, 2014 12:31 PM
  • I think the problem is with all the spaces.  For instance this:

    "!System      :"

    Get rid of the spaces in the code, and get rid of the spaces in the Worksheet.  Use the Function Trim().  That should work for you.


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

    Wednesday, August 20, 2014 12:32 PM
  • There are a few issues with this, which seems to have been cobbled from one of my earlier threads - see http://www.gmayor.com/extract_data_from_email.htm for a breakdown of how it works.

    In the case of your message format, the following should work

    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 strData As String
    Const strPath As String = "D:\maile.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
            Set xlApp = CreateObject("Excel.Application")
        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.Range("D" & xlSheet.Rows.Count).End(-4162).Row 'You need to select a column that will always have data - here D.
        For Each olItem In Application.ActiveExplorer.Selection
            rCount = rCount + 1 'This goes here not in the second loop
            sText = olItem.Body
            vText = Split(sText, Chr(13))
            'Find the next empty line of the worksheet

            'Check each line of text in the message body
            For i = 0 To UBound(vText) ' there is no real need in this case to process in reverse order
                strData = vText(i)
                strData = Replace(strData, Chr(160), Chr(32)) 'Replace any non-breaking spaces
                If Not Trim(strData) = vbNullString Then
                    'If InStr(1, vText(i), "Source:") > 0 Then 'There is no 'Source line in the sample
                    '    vItem = Split(vText(i), Chr(58))
                    '    xlSheet.Range("A" & rCount) = Trim(vItem(1))
                    'End If
                    If InStr(1, strData, "!System") > 0 Then
                        vItem = Split(strData, Chr(58))
                      'There are two separators in this line, so you need to address that e.g.                    xlSheet.Range("B" & rCount) = Trim(Replace(vItem(1), "Programme", ""))
                    End If
                    'as the search characters are unique you can limit the searches to the unique words.
                    If InStr(1, strData, "!Stückliste") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("C" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!Abnehmer") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("D" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!GO-Release") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("E" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!Vorgangs-Nr.") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("F" & rCount) = Trim(vItem(1))
                    End If
                End If
            Next i
            xlWB.Save
        Next olItem
        xlWB.Close SaveChanges:=True

        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 Peter Kania Thursday, August 21, 2014 12:18 PM
    Wednesday, August 20, 2014 1:03 PM
  • Seems like getting some small progress.
    Running macro now gives some effect - it wipes all in the excel file


    Edit.

    Ive addded

    'Insert some headers
    With xlSheet
        .Cells(1, 1) = "System"
        .Cells(1, 2) = "Stuckliste"
        .Cells(1, 3) = "Abnehmer"
        .Cells(1, 4) = "GO-Release"
        .Cells(1, 5) = "Vorgangs-Nr."

    Headers are created but the data still is not exported

    • Edited by Peter Kania Wednesday, August 20, 2014 1:22 PM
    Wednesday, August 20, 2014 1:07 PM
  • be aware of code like this: Application.ActiveExplorer.Selection

    I see different issues about this: you application has to be the active one (has to be in front of everything else). If you want to run this in batch, you might get some problems.

    also you're talking about "selection". So something needs to be selected. I think it's better to adress what you need more specific.

    In what environment are you unning your code? in VBS, VB6 or in outlook? If you are running this in a development environment, try to go into your code step by step (press F8). Also when debugging, put you "on error" - line in comment.

    Thursday, August 21, 2014 6:51 AM

  • Ok I have finally managed to export the data to excel with the following 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 strData As String
    Const strPath As String = "D:\maile.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
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
        'Open the workbook to input the data
        Set xlWB = xlApp.Workbooks.Open(strPath)
        Set xlSheet = xlWB.Sheets("Sheet1")


    'Insert some headers
    With xlSheet
        .Cells(1, 1) = "System"
        .Cells(1, 2) = "Stuckliste"
        .Cells(1, 3) = "Abnehmer"
        .Cells(1, 4) = "GO-Release"
        .Cells(1, 5) = "Vorgangs-Nr."

     End With
        'Process each selected record
        rCount = xlSheet.Range("D" & xlSheet.Rows.Count).End(-4162).Row
        For Each olItem In Application.ActiveExplorer.Selection
            rCount = rCount + 1
            sText = olItem.Body
            vText = Split(sText, Chr(13))
            'Find the next empty line of the worksheet

            'Check each line of text in the message body
            For i = 0 To UBound(vText)
                strData = vText(i)
                strData = Replace(strData, Chr(160), Chr(32))
                If Not Trim(strData) = vbNullString Then

                    If InStr(1, strData, "!System") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("A" & rCount) = Trim(vItem(1))

                    End If

                    If InStr(1, strData, "!Stückliste") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("B" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!Abnehmer") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("C" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!GO-Release") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("D" & rCount) = Trim(vItem(1))
                    End If

                    If InStr(1, strData, "!Vorgangs-Nr.") > 0 Then
                        vItem = Split(strData, Chr(58))
                        xlSheet.Range("E" & rCount) = Trim(vItem(1))
                    End If
                End If
            Next i
            xlWB.Save
        Next olItem
        xlWB.Close SaveChanges:=True

        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
        Set olItem = Nothing
    End Sub

    However, there is one more problem.

    Mail format is:

        !System      : xxx      Programme: xxxx

         !Stückliste  : xxx

    Reults in excel looks like this:

                   A                       B                   C                         D                        E
                SYSTEM            Stückliste    Abnehmer        GO-Release           Vorgangs-Nr.
    1   XXX  Programme                              XXX                    XXX                       XXX
    2   XXX  Programme                              XXX                     XXX                       XXX

    Any ideas?
    Thursday, August 21, 2014 7:48 AM
  • Ok, Ive figured it out. As VB doesnt recognize some special characters (ü in this case) the solution was to search from 5th character:

    Instead

    If InStr(1, strData, "!Stückliste") > 0 Then        -      If InStr(5, strData, "ckliste") > 0 Then

    Thursday, August 21, 2014 11:57 AM