Loading
Ozgrid Excel Help & Best Practices Forums

Excel Video Tutorials / Excel Dashboards Reports



Results 1 to 9 of 9

Thread: Exporting text from body of outlook email to excel

  1. #1
    Join Date
    19th October 2011
    Posts
    3

    Exporting text from body of outlook email to excel

    Hi,

    I would like some help regarding this, I have managed to export the whole body of an email to excel, but im having trouble doing this as im a newbie to vba.

    I want to retrieve the text after the colon from an email, the emails are always the same layout so thats not a problem, they look like this

    Store Number: 8078
    Item: SPACE PLANNING
    Date: 10-17-2011 11:13
    Requested Change: 1
    Category: PROMO WINE TOWERS CO11
    Sub-Category: 484
    Date Effective: 20-06-11
    Date Inactive: 31-12-99
    Fixture Size: 1 M BASE
    Equipment: WINE TOWERS
    Comments: we do not have a wine tower

    I would like the macro to take the information after the colons, store number, comments, category, etc and place them into an excel file with the headings the same. This would save a LOT of time as atm im doing it manually.

    ive been messing about with some coding but its hard to pick up when youre a complete noob like me! though im coming up short with this, I have managed to export the whole email body to excel but I dont know the coding for vba to go through the email and pick out the seperate texts. (If this is making any sense, lol)

    This would be MASSIVLY appreciated!!

    Thanks in advance

    Excel Video Tutorials / Excel Dashboards Reports


  2. #2
    Join Date
    1st September 2010
    Posts
    7,715

    Re: Exporting text from body of outlook email to excel

    Why not post your existing code so suggestions that fit in with your code can be made ...?

    Excel Video Tutorials / Excel Dashboards Reports


  3. #3
    Join Date
    19th October 2011
    Posts
    3

    Re: Exporting text from body of outlook email to excel

    good idea cytop

    here is my code, tho I have put it together from different sources and is apparant i have no idea what im doin as ive pasted in some that i thought might do what i want, which it didnt! anyway, here it is

    VB:
    Option Explicit 
    Private strTemplatesPath As String 
     
    Sub SaveMessagesToExcel() 
         
        On Error Goto ErrorHandler 
        Dim appExcel As Excel.Application 
        Dim wkb As Excel.Workbook 
        Dim wks As Excel.Worksheet 
        Dim rng As Excel.Range 
        Dim strSheet As String 
        Dim i As Integer 
        Dim j As Integer 
        Dim lngCount As Long 
        Dim msg As Outlook.MailItem 
        Dim nms As Outlook.NameSpace 
        Dim fld As Outlook.MAPIFolder 
        Dim nColonCharIndex As Integer 
        Dim nBodyLength As Integer 
        Dim nNewLineCharIndex As Integer 
        Dim nOutputRow, nOutputColumn As Integer 
         'Must declare as Object because folders may contain different
         'types of items
        Dim itm As Object 
        Dim strTitle As String 
        Dim strPrompt As String 
        strTemplatesPath = "C:\" 
        strSheet = "Messages.xls" 
        strSheet = strTemplatesPath & strSheet 
        Debug.Print "Excel workbook: " & strSheet 
         'Test for file in the Templates folder
        If TestFileExists(strSheet) = False Then 
            strTitle = "Worksheet file not found" 
            strPrompt = strSheet & _ 
            " not found; please copy Messages.xls to this folder and try again" 
            MsgBox strPrompt, vbCritical + vbOKOnly, strTitle 
            Goto ErrorHandlerExit 
        End If 
         
        Set appExcel = GetObject(, "Excel.Application") 
        appExcel.Workbooks.Open (strSheet) 
        Set wkb = appExcel.ActiveWorkbook 
        Set wks = wkb.Sheets(1) 
        wks.Activate 
        appExcel.Application.Visible = True 
         'Let user select a folder to export
        Set nms = Application.GetNamespace("MAPI") 
        Set fld = nms.PickFolder 
        If fld Is Nothing Then 
            Goto ErrorHandlerExit 
        End If 
         
         'Test whether selected folder contains mail messages
        If fld.DefaultItemType <> olMailItem Then 
            MsgBox "Folder does not contain mail messages" 
            Goto ErrorHandlerExit 
        End If 
         
        lngCount = fld.Items.Count 
         
        If lngCount = 0 Then 
            MsgBox "No messages to export" 
            Goto ErrorHandlerExit 
        Else 
            Debug.Print lngCount & " messages to export" 
        End If 
         
         'Adjust i (row number) to be 1 less than the number of the first body row
        i = 3 
         
         
         'Iterate through contact items in Contacts folder, and export a few fields
         'from each item to a row in the Contacts worksheet
        For Each itm In fld.Items 
            If itm.Class = olMail Then 
                 'Process item only if it is a mail item
                Set msg = itm 
                i = i + 1 
                 
                 'j is the column number
                j = 1 
                 
                Set rng = wks.Cells(i, j) 
                If msg.Subject <> "" Then rng.value = msg.Subject 
                j = j + 1 
                 
                Set rng = wks.Cells(i, j) 
                If msg.Body <> "" Then rng.value = msg.Body 
                j = j + 1 
                 
                Set rng = wks.Cells(i, j) 
                rng.value = msg.SentOn 
                j = j + 1 
                 
                Set rng = wks.Cells(i, j) 
                rng.value = msg.ReceivedTime 
                 
                j = j + 1 
                 
                Set rng = wks.Cells(i, j) 
                On Error Resume Next 
                 'The next line illustrates the syntax for referencing
                 'a custom Outlook field
                If msg.UserProperties("CustomField") <> "" Then 
                    rng.value = msg.UserProperties("CustomField") 
                End If 
                j = j + 1 
            End If 
        Next itm 
    ErrorHandlerExit: 
        Exit Sub 
    ErrorHandler: 
        If Err.Number = 429 Then 
             'Application object is not set by GetObject; use CreateObject instead
            If appExcel Is Nothing Then 
                Set appExcel = CreateObject("Excel.Application") 
                Resume Next 
            End If 
        Else 
            MsgBox "Error No: " & Err.Number & "; Description: " 
            Resume ErrorHandlerExit 
        End If 
    End Sub 
    Public Sub ParseBody(Body As String) 
         
         'get the total number of characters in the body
        Dim nBodyLength As Integer 
        nBodyLength = Len(Body) 
         
         'a place holder, that holds the position of : characters
        Dim nColonCharIndex As Integer 
        nColonCharIndex = 1 
         'a place holder, that holds the position of the new line character
        Dim nNewLineCharIndex As Integer 
         
         'row to output the information on for this example
        Dim nOutputRow, nOutputColumn As Integer 
        nOutputRow = 1 
        nOutputColumn = 1 
         
         'while the colon character index is less than the body's length
        While nColonCharIndex < nBodyLength 
             
             'find a occurance of  :
            nColonCharIndex = InStr(nColonCharIndex, Body, ":") 
             'from here find the next occurance of new line
            nNewLineCharIndex = InStr(nColonCharIndex, Body, vbCrLf) 
             
             'if the newline character search result comes back with zero,
             'then we are at the end of the string, so
            If nNewLineCharIndex = 0 Then 
                 'set the new line character to the end of the string
                nNewLineCharIndex = InStr(nColonCharIndex, Body, vbCrLf) 
            End If 
             
             'output a substring of the main body text
             'from the next character after the :
             'for the amount of characters between the : and the new line (-1 leaves off trailing new line)
            ActiveSheet.Cells(nOutputRow, nOutputColumn).value = _ 
            Mid(Body, nColonCharIndex + 1, nNewLineCharIndex - nColonCharIndex - 1) 
             
             'increment output
            nOutputRow = nOutputRow + 1 
             
             'move the indexes to their new starting positions
            nColonCharIndex = nNewLineCharIndex + 1 
            nNewLineCharIndex = nNewLineCharIndex + 1 
             
        Wend 
    End Sub 
     
    Public Function TestFileExists(strFile As String) As Boolean 
         
        Dim fso As New Scripting.FileSystemObject 
        Dim fil As Scripting.File 
         
        On Error Resume Next 
        Set fil = fso.GetFile(strFile) 
        If fil Is Nothing Then 
            TestFileExists = False 
        Else 
            TestFileExists = True 
        End If 
         
    End Function 
    Public Function GetTemplatesPath() As String 
         
        Dim appWord As Word.Application 
        Set appWord = GetObject(, "Word.Application") 
         
        strTemplatesPath = _ 
        appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\" 
        Debug.Print "Templates folder: " & strTemplatesPath 
        GetTemplatesPath = strTemplatesPath 
         
    ErrorHandlerExit: 
        Set appWord = Nothing 
        Exit Function 
    ErrorHandler: 
        If Err = 429 Then 
             'Word is not running; open Word with CreateObject
            Set appWord = CreateObject("Word.Application") 
            Resume Next 
        Else 
            MsgBox "Error No: " & Err.Number & "; Description: " _ 
            & Err.Description 
            Resume ErrorHandlerExit 
        End If 
    End Function 
    
    
    Thank you

    Excel Video Tutorials / Excel Dashboards Reports


  4. #4
    Join Date
    19th October 2011
    Posts
    3

    Re: Exporting text from body of outlook email to excel

    has my relpy worked?

    Excel Video Tutorials / Excel Dashboards Reports


  5. #5
    Join Date
    24th October 2011
    Posts
    106

    Re: Exporting text from body of outlook email to excel

    Dear Greylegface,

    Forget what you are using ,use this code ,i will do more than you want .....not only will you get expected results ,you will have a dynamic counter as the results happen so that you can see from front end in cell A1 loop numbers as data gets processed like A1,2,3,4,5,6,7,8 9 etc in a mind blowing fashion .....also at Cell A1 you will see the time needed for this macro to execute ,

    Just one favor ,i assume that you can paste your data in column A and replace Sub - Category by Sub -category ,your data is like
    Store Number: 8078
    Item: SPACE PLANNING
    Date: 10-17-2011 11:13
    Requested Change: 1
    Category: PROMO WINE TOWERS CO11
    Sub-Category: 484
    Date Effective: 20-06-11
    Date Inactive: 31-12-99
    Fixture Size: 1 M BASE
    Equipment: WINE TOWERS
    Comments: we do not have a wine tower

    Most Important -Here i request that you select this entire column and replace Sub-Category by Sub-category and then run this macro .....why ?Because when i use ins statement to find Category then it is getting confused by the 2 field names being identical ...so simply replace Sub-Category by Sub-category



    I am presuming that you are using excel 2007 and so when i give the range statement i use Range("A1048576") indicating that many rows but if you use any otherversion you can simply use than many rows ,see your excel file ,if you see that the last row is 65000 odd ,then put that instead of this ....but first run thsi and get back ....


    I have always appreciated nice looking sheets ,so i will do more ,i will make your input sheet wrapped ,font chaged to calibri ,text size 12 ,boundaries applied and alignment to top left ....and as it all happens you can see the dynamic ticker moving as it happens in front of your eyes like magic ...not only that you will time execution in cell A1 ...
    also for macro execution ,i have kept a neat arrow and assigned the macro to it so that the sheet gets a killing feel ,



    Anyways here's the code ,

    VB:
    Sub dataextractionrev() 
         'Declare variables to be used
        Dim I As Long 
        Dim lenghtoftexttext As Long 
        Dim timeforexceution As Single 
         
         
        timeforexecution = Timer 
         
         
        str1 = "Store Number: " 
        str2 = "Item: " 
        str3 = "Date: " 
        str4 = "Requested Change: " 
        str5 = "Category: " 
        str6 = "Sub-category: " 
        str7 = "Date Effective: " 
        str8 = "Date Inactive: " 
        str9 = "Fixture Size: " 
        str10 = "Equipment: " 
        str11 = "Comments: " 
         
         
        Sheets("Sheet1").Select 
         
         
        Cells(1, "B").Value = "Store Number " 
        Cells(1, "C").Value = "Item " 
        Cells(1, "D").Value = "Date " 
        Cells(1, "E").Value = "Requested Change " 
        Cells(1, "F").Value = "Category" 
        Cells(1, "G").Value = "Sub-category " 
        Cells(1, "H").Value = "Date effective " 
        Cells(1, "I").Value = "Date inactive " 
        Cells(1, "J").Value = "Fixture Size " 
        Cells(1, "K").Value = "Equipment " 
        Cells(1, "L").Value = "Comments " 
         
         
         
         
         
         
         
         
         
         
        Finalrow = Range("A1048576").End(xlUp).Row 
         
         
         
         
        For I = 2 To Finalrow 
             
             
            If Len(Sheets("Sheet1").Cells(I, "A").Value) > 40 Then 
                 'Variables to find the position of str1-11 from the original data
                post1 = InStrRev(Cells(I, "A"), str1) 
                post2 = InStrRev(Cells(I, "A"), str2) 
                post3 = InStrRev(Cells(I, "A"), str3) 
                post4 = InStrRev(Cells(I, "A"), str4) 
                post5 = InStrRev(Cells(I, "A"), str5) 
                post6 = InStrRev(Cells(I, "A"), str6) 
                post7 = InStrRev(Cells(I, "A"), str7) 
                post8 = InStrRev(Cells(I, "A"), str8) 
                post9 = InStrRev(Cells(I, "A"), str9) 
                post10 = InStrRev(Cells(I, "A"), str10) 
                post11 = InStrRev(Cells(I, "A"), str11) 
                 
                 
                 
                 
                 
                 
                 
                 
                 
                 
                 
                 
                 
                 
                lentext = Len(Cells(I, "A")) 
                 'This extracts the data from the raw data into their respective cells (Store number ,item ,date .....e.t.c)
                 
                 
                Cells(I, "B").Value = Mid(Cells(I, "A"), post1 + Len(str1), post2 - post1 - Len(str1) - 1) 
                Cells(I, "C").Value = Mid(Cells(I, "A"), post2 + Len(str2), post3 - post2 - Len(str2) - 1) 
                Cells(I, "D").Value = Mid(Cells(I, "A"), post3 + Len(str3), post4 - post3 - Len(str3) - 1) 
                Cells(I, "E").Value = Mid(Cells(I, "A"), post4 + Len(str4), post5 - post4 - Len(str4) - 1) 
                Cells(I, "F").Value = Mid(Cells(I, "A"), post5 + Len(str5), post6 - post5 - Len(str5) - 1) 
                Cells(I, "G").Value = Mid(Cells(I, "A"), post6 + Len(str6), post7 - post6 - Len(str6) - 1) 
                Cells(I, "H").Value = Mid(Cells(I, "A"), post7 + Len(str7), post8 - post7 - Len(str7) - 1) 
                Cells(I, "I").Value = Mid(Cells(I, "A"), post8 + Len(str8), post9 - post8 - Len(str8) - 1) 
                Cells(I, "J").Value = Mid(Cells(I, "A"), post9 + Len(str9), post10 - post9 - Len(str9) - 1) 
                Cells(I, "K").Value = Mid(Cells(I, "A"), post10 + Len(str10), post11 - post10 - Len(str10) - 1) 
                 
                 
                Cells(I, "L").Value = Right(Cells(I, "A"), lentext - post10 - Len(str10) + 1) 
                 
                 
                 
                 
                 
                 
            End If 
            Cells(1, "B").Value = "Store Number ,Dynamic Count =  A" & I - 1 
        Next I 
         
         
         
         
        Cells(1, "A").Value = "Message Body ,Simple conversion time " & Format(Timer - timeforexecution, "0.000 secs") 
         
         
        Columns("A:L").Select 
         
        With Selection 
            .HorizontalAlignment = xlLeft 
            .VerticalAlignment = xlTop 
            .WrapText = True 
            .Orientation = 0 
            .AddIndent = False 
            .IndentLevel = 0 
            .ShrinkToFit = False 
            .ReadingOrder = xlContext 
            .MergeCells = False 
        End With 
         
         ' make font calibri and do font size 12
         
        With Selection.Font 
            .Name = "Calibri" 
            .Size = 14 
            .Bold = False 
            .Strikethrough = False 
            .Superscript = False 
            .Subscript = False 
            .OutlineFont = False 
            .Shadow = False 
            .Underline = xlUnderlineStyleNone 
            .ColorIndex = xlAutomatic 
            .TintAndShade = 0 
            .ThemeFont = xlThemeFontMinor 
        End With 
         
         
         
         'make font color light blue in outpt sheet
        With Selection.Font 
            .ThemeColor = xlThemeColorLight2 
            .TintAndShade = 0 
        End With 
         
         ' apply boundaries to sheet
        Sheets("Sheet1").Select 
        Columns("A:L").Select 
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone 
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone 
        With Selection.Borders(xlEdgeLeft) 
            .LineStyle = xlContinuous 
            .ColorIndex = 0 
            .TintAndShade = 0 
            .Weight = xlThin 
        End With 
        With Selection.Borders(xlEdgeTop) 
            .LineStyle = xlContinuous 
            .ColorIndex = 0 
            .TintAndShade = 0 
            .Weight = xlThin 
        End With 
        With Selection.Borders(xlEdgeBottom) 
            .LineStyle = xlContinuous 
            .ColorIndex = 0 
            .TintAndShade = 0 
            .Weight = xlThin 
        End With 
        With Selection.Borders(xlEdgeRight) 
            .LineStyle = xlContinuous 
            .ColorIndex = 0 
            .TintAndShade = 0 
            .Weight = xlThin 
        End With 
        With Selection.Borders(xlInsideVertical) 
            .LineStyle = xlContinuous 
            .ColorIndex = 0 
            .TintAndShade = 0 
            .Weight = xlThin 
        End With 
        With Selection.Borders(xlInsideHorizontal) 
            .LineStyle = xlContinuous 
            .ColorIndex = 0 
            .TintAndShade = 0 
            .Weight = xlThin 
        End With 
         
         
    End Sub 
    
    

    I won't mind explaining the code but i have kept it very simple so that you can esily understand it ,i had a similar query so when someone explianed his solution ,i learnt it ...today for the simple fact that i learnt the solution ,i could solve your query ...if you can learn from my solution ,tommorow ,you will be able to help someone like i do ,
    just hope that come that day ,you will help someone ,


    Run the code and get back ,i will solve this completely for you ,


    See the attachment ,i have solved it for you ,


    Humble Regard's,


    Amlan Dutta

    i dunno whether you are still following this thread ,
    Attached Files. REMINDER! OzGrid accepts no responsibility for ANY adverse effects as a result from downloading attached files. ALWAYS run an up-to-date virus scan and disable macros.

    Excel Video Tutorials / Excel Dashboards Reports


  6. #6
    Join Date
    7th September 2012
    Posts
    1

    Re: Exporting text from body of outlook email to excel

    Hi Amlan Dutta,

    I had read your solution. Its very good. I had came across the same type of solution.Capture.jpg

    I have Mail's with body containing excel data coming from one mailing address. I need to export automatically the entire body of the mail in to an excel sheet when ever a new such mail comes into my inbox folder.
    Can anyone please let me know the procedure to solve it.

    Attached is the mail screeshot.

    Thanks in advance,
    Mahi

    Excel Video Tutorials / Excel Dashboards Reports


  7. #7
    Join Date
    1st September 2010
    Posts
    7,715

    Re: Exporting text from body of outlook email to excel

    Please do not post questions in threads started by other members.

    Start your own thread, give it an accurate and concise title and describe your issue fully.

    If you think this thread can help to clarify or explain your problem, you can include a link to it by copying the URL from the address bar of your browser and pasting into your message.

    Excel Video Tutorials / Excel Dashboards Reports


  8. #8
    Join Date
    14th May 2013
    Posts
    1

    Re: Exporting text from body of outlook email to excel

    My requirement is on simillar basis so i copied this code directly and run this
    i got following error-

    compile error:
    Sub or function not defined

    can you please explain in detail on how to run this code

    Excel Video Tutorials / Excel Dashboards Reports


  9. #9
    Join Date
    1st September 2010
    Posts
    7,715

    Re: Exporting text from body of outlook email to excel

    Please refer to post #7 above

    Excel Video Tutorials / Excel Dashboards Reports


Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Possible Answers

  1. Send Email Via Outlook With Body Text
    By jimbean in forum Excel and/or Email Help
    Replies: 2
    Last Post: August 22nd, 2007, 00:05
  2. Exporting text from email body to excel
    By clees in forum Excel and/or Email Help
    Replies: 7
    Last Post: February 6th, 2006, 15:44
  3. formatted text in body of outlook email
    By WWiener in forum Excel and/or Email Help
    Replies: 3
    Last Post: January 14th, 2005, 23:55
  4. Email: Formating Email Body w/ VBA excel / Outlook
    By JJacob in forum Excel and/or Email Help
    Replies: 2
    Last Post: October 27th, 2003, 08:25

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
porno