Exporting text from body of outlook email to excel

[greylegface]

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

[cytop]

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

[greylegface]

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

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

[greylegface]

has my relpy worked?

[amlan009]

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 ,

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 ,

[mahi_lvs]

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

[cytop]

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.

[raja1234]

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

[cytop]

Please refer to post #7 above