none
VBA Outlook export Email body to excel RRS feed

  • Question

  • I have been trying to do this on my own for two days now with limited success.  I have a list of elements from a contact form that are received in an email as follows.  In addition to main issue as covered below I would like to be able to.

    1) Automate this so that it runs on its own each time an email fitting the subject description arrives in the mail box.

    2) Copy the processed emails into the same folder each time as opposed to a new one each time.

    3) Be able to Designate exactly what folder I want it to run on as I have 4 or 5  “In boxes” set up in outlook.

    4) Perhaps add time and date received info to the export.

    5) Rename the attachments to coincide with the cell row number of the saved email it came with

    These 5 found above would be nice to have…the addition of the MESSAGE:/QUESTION: data as described below is a must.

    SALUTATION:xx.

    FIRSTNAME:xxxxxxxx

    LASTNAME:xxxxxx

    STREET:1234 xxxxxxx

    ZIPCODE:xxxxx

    CITY:xxxxxxxxxxx

    STATE:xxx

    COUNTRY:xxxxxxxxx

    EMAIL:xxxxxxx@xxxxxxxx.xxx

    PHONE:##########

    PRODUCT_NAME:xxxxxxxxx

    POS_CITY:xxxxxxxxx

    BATCHNO:xxxxxxxxxx

    MHD:xxxxxxxxxx

    POS_NAME:xxxxxxxxx

    PACKING_TIME:xxxxxxxx

    PACKING_SIZE:xxxxxxxxx

    CATEGORY:xxxxxxxxx

    MESSAGE:

    Xxxxxxxxxxxxxxxxxxxxxxxxxxxxx

    The code I have found works well for all elements EXCEPT for the last one “MESSAGE:” as the text for it does not start until the next line as shown in the example.  I will need to add additional elements as well as this code only covers 7...with apparent "Special" code for the email address and phone. In addition, there are two versions of this form as well where the “MESSAGE:” heading is replaced by “QUESTION:”.  They are always on the last line and we have had people fill 10 or 15 lines of text here.  I would appreciate if anyone could help me understand what I need to do with this code to account for this issue?  Here is the code I have found…

    [CODE]

    ' Outlook Macro for moving specific mails and reading their content
    ' Version: 1.0 (VBA version: 7.0)
    ' Date: 8/26/2012
    ' Author: Nedim Sahin
    ' Web site: www.birvesifir.com
    ' Contact: nedim@nedimsahin.net
    '
    ' Summary: What does this macro do? (Step by step)
    '  - Find the mails which have the specific subject in Inbox folder
    '    (In this case, subject is "create call")
    '  - Creating a folder named like "Processed Emails  8/26/2012 1:29:50 PM" under Inbox.
    '  - Moving those mails to "Inbox > Processed Emails  8/26/2012 1:29:50 PM"
    '  - Creating a folder named like "Processed Emails  8/26/2012 1:29:50 PM" under C: drive
    '  - Saving those mails' attachments under "C:\Processed Emails  8/26/2012 1:29:50 PM"
    '  - Reading content of those mails and creating Excel file
    '
    ' Notes:
    '  - A reference named "Microsoft Excel 14.0 Object Library" must be added
    '  - It searchs mails under only Inbox folder
    '
    ' Special thanks:
    '  - http://www.techonthenet.com/excel

    Sub resumemails() ' Main subroutine
        ' Declare all variables.
        Dim objOutlook As Outlook.Application
        Dim objNamespace As Outlook.NameSpace
        Dim objSourceFolder As Outlook.MAPIFolder
        Dim objDestFolder As Outlook.MAPIFolder
        Dim objVariant As Variant
        Dim lngMovedMailItems As Long
        Dim intCount As Integer
        Dim title As String
        Dim strDestFolder As String
        Dim folderName As String
        Dim folderNameCdrive As String
        Dim fs As Object
        Dim Item As Object
        Dim Atmt As Attachment
        Dim FileName As String
        Dim temp As String
        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 i As Long
        Dim rCount As Long

        ' Setting first values
        Set objOutlook = Application
        Set objNamespace = objOutlook.GetNamespace("MAPI")
        Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)

        ' Creating and setting folders
        folderName = "Processed Emails " & DateTime.Now()
        Set objDestFolder = objSourceFolder.Folders.Add(folderName)
        Set fs = CreateObject("Scripting.FileSystemObject")
        folderNameCdrive = "C:\" & "Processed Emails " & Replace(DateTime.Now(), ":", "-")
        folderNameCdrive = Replace(folderNameCdrive, "/", "-")
        fs.CreateFolder folderNameCdrive

        ' Move resume mails to "Inbox\Resumes DateTime"
        For intCount = objSourceFolder.Items.Count To 1 Step -1
            Set objVariant = objSourceFolder.Items.Item(intCount)
            DoEvents
            If objVariant.Class = olMail Then
                Debug.Print objVariant.SentOn
                title = objVariant.Subject
                If title = "create call" Then
                    objVariant.Move objDestFolder
                    lngMovedMailItems = lngMovedMailItems + 1
                End If
            End If
        Next

        ' Save attached resumes to "C:\Processed Emails DateTime"
        For Each Item In objDestFolder.Items
            For Each Atmt In Item.Attachments
                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                    FileName = folderNameCdrive & "\" & Atmt.FileName
                    Atmt.SaveAsFile FileName
                    FileName = Mid(FileName, 1, InStrRev(FileName, ".") - 1)
                End If
            Next Atmt
        Next Item

        ' Setting Excel values
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        Set xlWB = xlApp.Workbooks.Add
        Set xlSheet = xlWB.Worksheets(1)
        rCount = rCount + 1

        ' Process each resume mail
        For Each olItem In objDestFolder.Items
            sText = olItem.Body
            vText = Split(sText, Chr(13))

            rCount = rCount + 1

            ' Columns names
            xlSheet.Range("A1") = "SALUTATION"
            xlSheet.Range("B1") = "FIRSTNAME"
            xlSheet.Range("C1") = "LASTNAME"
            xlSheet.Range("D1") = "STREET"
            xlSheet.Range("E1") = "ZIPCODE"
            xlSheet.Range("F1") = "CITY"
            xlSheet.Range("G1") = "STATE"
            xlSheet.Range("H1") = "COUNTRY"
            xlSheet.Range("I1") = "EMAIL"
            xlSheet.Range("J1") = "PHONE"
            xlSheet.Range("K1") = "PRODUCT_NAME"
            xlSheet.Range("L1") = "POS_CITY"
            xlSheet.Range("M1") = "BATCHNO"
            xlSheet.Range("N1") = "MHD"
            xlSheet.Range("O1") = "POS_NAME"
            xlSheet.Range("P1") = "PAKING_TIME"
            xlSheet.Range("Q1") = "PAKING_SIZE"
            xlSheet.Range("R1") = "CATEGORY"
            xlSheet.Range("S1") = "MESSAGE/QUESTION"

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

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

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

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

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

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

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

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

                If InStr(1, vText(i), "EMAIL:") > 0 Then
                    temp2 = InStrRev(vText(i), ":")
                    temp3 = InStr(temp2 + 1, vText(i), Chr(34))
                    If temp3 < temp2 Then ' If there is a link, this "If" statement handles it
                        vItem = Split(vText(i), Chr(58))
                    Else
                        vItem(1) = Mid(vText(i), temp2 + 1, temp3 - temp2 - 1)
                    End If
                    xlSheet.Range("I" & rCount) = LTrim(cleanIt(CStr(vItem(1))))
                End If

                If InStr(1, vText(i), "PHONE:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("J" & rCount).NumberFormat = "@"
                    xlSheet.Range("J" & rCount) = LTrim(cleanIt(CStr(vItem(1))))
                End If

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

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

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

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

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

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

                If InStr(1, vText(i), "PAKING_SIZE:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("Q" & rCount) = LTrim(cleanIt(CStr(vItem(1))))
                End If

                If InStr(1, vText(i), "CATEGORY:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("R" & rCount) = LTrim(cleanIt(CStr(vItem(1))))
                End If

                If InStr(1, vText(i), "MESSAGE:            ") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("S" & rCount) = LTrim(cleanIt(CStr(vItem(1))))
                End If

                If InStr(1, vText(i), "QUESTION:") > 0 Then
                    vItem = Split(vText(i), Chr(58))
                    xlSheet.Range("S" & rCount) = LTrim(cleanIt(CStr(vItem(1))))
                End If

            Next i
        Next olItem

        ' Beautification
        xlSheet.Columns("A:S").AutoFit
        xlSheet.Range("A1:S1").Interior.Color = RGB(30, 144, 255)
        xlSheet.Range("A1:S1").Font.Color = RGB(248, 248, 255)

        ' Relasing the object
        Set objDestFolder = Nothing

    End Sub

    Function cleanIt(text As String) As String ' Clean spaces and unprintable characters

        Dim temp1 As String
        Dim temp2 As Integer

        temp1 = Trim(text)

        If temp1 <> "" Then
            temp2 = Asc(Left(temp1, 1))
            If temp2 < 33 Or temp2 = 160 Then
                temp1 = Right(temp1, Len(temp1) - 1)
            End If
        End If

        cleanIt = temp1

    End Function

    [/CODE]

                                                                                                                                                                                                                                                                         
    Thursday, December 18, 2014 1:39 AM