Announcement

Collapse
No announcement yet.

Exporting text from body of outlook email to excel

Collapse
This topic is closed.
X
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • 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

  • #2
    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 ...?

    Comment


    • #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

      Code:
      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

      Comment


      • #4
        Re: Exporting text from body of outlook email to excel

        has my relpy worked?

        Comment


        • #5
          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 ,

          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 ,
          Attached Files

          Comment


          • #6
            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.Click image for larger version

Name:	Capture.jpg
Views:	1
Size:	46.6 KB
ID:	1108622

            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

            Comment


            • #7
              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.

              Comment


              • #8
                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

                Comment


                • #9


                  Re: Exporting text from body of outlook email to excel

                  Please refer to post #7 above

                  Comment

                  Working...
                  X