Prakash28
11-26-2017, 10:00 PM
I need help in extracting body of outlook mail which contains columns and rows into a excel sheet through vba
below code will copy body in 1 column.
Option Explicit
Public gblStopProcessing As Boolean
Sub ParseBlockingSessionsEmailPartOne()
' This macro requires Microsoft Outlook Object Library (Menu: Tools/References) be available
Dim wb As Workbook
Dim ws As Worksheet
Dim objFolder As Object
Dim objNSpace As Object
Dim objOutlook As Outlook.Application
Dim lngAuditRecord As Long
Dim lngCount As Long
Dim lngTotalItems As Long 'Count of emails in the Outlook folder.
Dim lngTotalRecords As Long
Dim i As Integer
Dim EmailCount As Integer 'The counter, which starts at zero.
'
On Error GoTo HandleError
'Application.ScreenUpdating = True
'Application.ScreenUpdating = False
'
Sheets("Sheet1").Select
'
' Initialize:
Set wb = ThisWorkbook
lngAuditRecord = 1 ' Start row
lngTotalRecords = 0
'
' Read email messages:
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objNSpace = objOutlook.GetNamespace("MAPI")
'
' Allow user to choose folder:#
Set objFolder = objNSpace.PickFolder
' Check if cancelled:
If objFolder Is Nothing Then
gblStopProcessing = True
MsgBox "Processing cancelled"
Exit Sub
End If
'
lngTotalItems = objFolder.Items.Count
If lngTotalItems = 0 Then
MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
gblStopProcessing = True
GoTo HandleExit
End If
If lngTotalItems > 0 Then
On Error Resume Next
Application.DisplayAlerts = False
wb.Worksheets("Sheet1").Delete
'wb.Worksheets("Audit").Delete
Application.DisplayAlerts = True
On Error GoTo HandleError
wb.Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = ActiveSheet
ws.Name = "Merge Data"
'Insert Title Row and Format NOTE: THE MACRO CAN BE USED TO PARSE OUT OTHER PARTS OF AN EMAIL.
' I JUST COMMENTED OUT THE LINES NOT USED FOR THE CURRENT PROJECT.
ws.Cells(1, 1) = "Received"
ws.Cells(1, 2) = "Email Body"
ws.Cells(lngAuditRecord, 3) = "Subject"
'ws.Cells(lngAuditRecord, 4) = "Attachments Count"
'ws.Cells(lngAuditRecord, 4) = "Sender Name"
'ws.Cells(lngAuditRecord, 5) = "Sender Email"
ws.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
Selection.EntireRow.Font.Bold = True
Selection.HorizontalAlignment = xlCenter
'Populate the workbook
For lngCount = 1 To lngTotalItems
Application.StatusBar = "Reading message " & lngCount & " of " & lngTotalItems
i = 0
'read email info
While i < lngTotalItems
i = i + 1
If i Mod 50 = 0 Then Application.StatusBar = "Reading email messages " & Format(i / lngTotalItems, "0%") & "..."
With objFolder.Items(i)
Cells(i + 1, 1).Formula = .ReceivedTime
Cells(i + 1, 2).Formula = .Body
Cells(i + 1, 3).Formula = .Subject
'Cells(i + 1, 4).Formula = .Attachments.Count
'Cells(i + 1, 5).Formula = .SenderName
'Cells(i + 1, 6).Formula = .SenderEmailAddress
End With
Wend
'Set objFolder = Nothing
ws.Activate
Next lngCount
lngTotalRecords = lngCount
'Format Worksheet
Columns("B:B").Select
Selection.ColumnWidth = 255
Cells.Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit
With Selection
.VerticalAlignment = xlTop
End With
Range("A1").Select
End If
'
' Check that records have been found:
If lngTotalRecords = 0 Then
MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
gblStopProcessing = True
GoTo HandleExit
End If
'
With Selection
Cells.Select
.VerticalAlignment = xlTop
.WrapText = True
End With
Range("A1").Select
'
HandleExit:
On Error Resume Next
Application.ScreenUpdating = True
Set objNSpace = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
Set ws = Nothing
Set wb = Nothing
If Not gblStopProcessing Then
MsgBox "Processing completed" & vbCrLf & vbCrLf & _
"Please check results", vbOKOnly + vbInformation, "Information"
End If
Call ParseBlockingSessionsEmailPartTwo
Exit Sub
'
HandleError:
MsgBox Err.Number & vbCrLf & Err.Description
gblStopProcessing = True
Resume HandleExit
End Sub
Sub ParseBlockingSessionsEmailPartTwo()
Dim vPrevChar10 As Integer
Dim vNextChar10 As Integer
Dim vCounter As Integer
Dim vLastEmail As Long
Dim vEmailBody As String
Dim vRowsInEmail As Integer
Dim vRecordCounter As Integer
Application.ScreenUpdating = True
Application.StatusBar = "Emails imported. Working on parsing the data therein."
Application.ScreenUpdating = False
Sheets("Merge Data").Select
Columns("B:B").Select 'Following gets rid of the email body content that comes prior to the data table
Selection.Replace What:="Blocking Sessions Check" & Chr(32) & Chr(13) & Chr(10) & Chr(13) & Chr(10) & Chr(13) & Chr(10), Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
vCounter = 1
vNextChar10 = 0
vRecordCounter = 1
With ActiveSheet
vLastEmail = .Cells(.Rows.Count, "B").End(xlUp).Row 'Last row in Column-B
End With
For vRecordCounter = 2 To vLastEmail 'Performs internal operation, one row per email, starting at B2.
Range("B" & vRecordCounter).Select
vEmailBody = ActiveCell.Value
vRowsInEmail = Len(vEmailBody) - Len(Replace(vEmailBody, Chr(10), "")) + 1 'Counts the number of line returns in the email body and adds one to get the rows in the body
With Range("B" & vRecordCounter & ":B" & vRecordCounter)
For vCounter = 1 To vRowsInEmail 'Will add a column to each row for each line in the email body
vPrevChar10 = vNextChar10 + 1
vNextChar10 = InStr(vPrevChar10, ActiveCell.Value, Chr(10))
.Offset(, vCounter + 1) = "=IFERROR(MID($B" & vRecordCounter & "," & vPrevChar10 & "," & vNextChar10 - vPrevChar10 + 0 & "), RIGHT($B" & vRecordCounter & ", LEN($B" & vRecordCounter & ") - " & vPrevChar10 - 1 & "))"
Next
End With
Next
' Call ParseBlockingSessionsEmailPartThree
End Sub
Sub ParseBlockingSessionsEmailPartThree()
Dim vmdLastEmail As Long
Dim vmdRow As Integer
Dim vdRowA As Integer
Dim vdRowB As Integer
Application.ScreenUpdating = True
Application.StatusBar = "Emails imported. Data parsed. Working on formatting the data."
Application.ScreenUpdating = False
vmdRow = 2
'While in Merge Data worksheet
Sheets("Sheet1").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
With ActiveSheet
vmdLastEmail = .Cells(.Rows.Count, "B").End(xlUp).Row 'Last row in Column-B of Merge Data worksheet
End With
'While in Merge Data worksheet
For vmdRow = 2 To vmdLastEmail
Sheets("Merge Data").Select
Range("B" & vmdRow).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'While in Data worksheet
Sheets("Data").Select
Range("A1").Select
With ActiveSheet
vdRowA = .Cells(.Rows.Count, "A").End(xlUp).Row 'Last row in Column-A of Merge Data worksheet
End With
Range("B1").Select
With ActiveSheet
vdRowB = .Cells(.Rows.Count, "B").End(xlUp).Row 'Last row in Column-B of Merge Data worksheet
End With
Range("B" & vdRowB).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
With ActiveSheet
vdRowB = .Cells(.Rows.Count, "B").End(xlUp).Row 'NEW last row in Column-B
End With
'Back to Merge Data worksheet
Sheets("Sheet1").Select
Range("A" & vmdRow).Select
Selection.Copy
'Back to Data worksheet
Sheets("Data").Select
Range("A" & vdRowA & ":A" & vdRowB).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next
Range("A2").Select
'Wrap it up
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "EMAIL_DATE-TIME"
Range("B1").Select
ActiveCell.FormulaR1C1 = "BLOCKING-SESSION-RECORD"
Range("A1:B1").Select
Selection.Font.Bold = True
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
Application.StatusBar = "All done. Emails imported, data parsed and formatted (a little)."
MsgBox "All done. Have fun."
ActiveWindow.FreezePanes = True
Cells.Select
Selection.Columns.AutoFit
Range("C1").Select
End Sub
below code will copy body in 1 column.
Option Explicit
Public gblStopProcessing As Boolean
Sub ParseBlockingSessionsEmailPartOne()
' This macro requires Microsoft Outlook Object Library (Menu: Tools/References) be available
Dim wb As Workbook
Dim ws As Worksheet
Dim objFolder As Object
Dim objNSpace As Object
Dim objOutlook As Outlook.Application
Dim lngAuditRecord As Long
Dim lngCount As Long
Dim lngTotalItems As Long 'Count of emails in the Outlook folder.
Dim lngTotalRecords As Long
Dim i As Integer
Dim EmailCount As Integer 'The counter, which starts at zero.
'
On Error GoTo HandleError
'Application.ScreenUpdating = True
'Application.ScreenUpdating = False
'
Sheets("Sheet1").Select
'
' Initialize:
Set wb = ThisWorkbook
lngAuditRecord = 1 ' Start row
lngTotalRecords = 0
'
' Read email messages:
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objNSpace = objOutlook.GetNamespace("MAPI")
'
' Allow user to choose folder:#
Set objFolder = objNSpace.PickFolder
' Check if cancelled:
If objFolder Is Nothing Then
gblStopProcessing = True
MsgBox "Processing cancelled"
Exit Sub
End If
'
lngTotalItems = objFolder.Items.Count
If lngTotalItems = 0 Then
MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
gblStopProcessing = True
GoTo HandleExit
End If
If lngTotalItems > 0 Then
On Error Resume Next
Application.DisplayAlerts = False
wb.Worksheets("Sheet1").Delete
'wb.Worksheets("Audit").Delete
Application.DisplayAlerts = True
On Error GoTo HandleError
wb.Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = ActiveSheet
ws.Name = "Merge Data"
'Insert Title Row and Format NOTE: THE MACRO CAN BE USED TO PARSE OUT OTHER PARTS OF AN EMAIL.
' I JUST COMMENTED OUT THE LINES NOT USED FOR THE CURRENT PROJECT.
ws.Cells(1, 1) = "Received"
ws.Cells(1, 2) = "Email Body"
ws.Cells(lngAuditRecord, 3) = "Subject"
'ws.Cells(lngAuditRecord, 4) = "Attachments Count"
'ws.Cells(lngAuditRecord, 4) = "Sender Name"
'ws.Cells(lngAuditRecord, 5) = "Sender Email"
ws.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
Selection.EntireRow.Font.Bold = True
Selection.HorizontalAlignment = xlCenter
'Populate the workbook
For lngCount = 1 To lngTotalItems
Application.StatusBar = "Reading message " & lngCount & " of " & lngTotalItems
i = 0
'read email info
While i < lngTotalItems
i = i + 1
If i Mod 50 = 0 Then Application.StatusBar = "Reading email messages " & Format(i / lngTotalItems, "0%") & "..."
With objFolder.Items(i)
Cells(i + 1, 1).Formula = .ReceivedTime
Cells(i + 1, 2).Formula = .Body
Cells(i + 1, 3).Formula = .Subject
'Cells(i + 1, 4).Formula = .Attachments.Count
'Cells(i + 1, 5).Formula = .SenderName
'Cells(i + 1, 6).Formula = .SenderEmailAddress
End With
Wend
'Set objFolder = Nothing
ws.Activate
Next lngCount
lngTotalRecords = lngCount
'Format Worksheet
Columns("B:B").Select
Selection.ColumnWidth = 255
Cells.Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit
With Selection
.VerticalAlignment = xlTop
End With
Range("A1").Select
End If
'
' Check that records have been found:
If lngTotalRecords = 0 Then
MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
gblStopProcessing = True
GoTo HandleExit
End If
'
With Selection
Cells.Select
.VerticalAlignment = xlTop
.WrapText = True
End With
Range("A1").Select
'
HandleExit:
On Error Resume Next
Application.ScreenUpdating = True
Set objNSpace = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
Set ws = Nothing
Set wb = Nothing
If Not gblStopProcessing Then
MsgBox "Processing completed" & vbCrLf & vbCrLf & _
"Please check results", vbOKOnly + vbInformation, "Information"
End If
Call ParseBlockingSessionsEmailPartTwo
Exit Sub
'
HandleError:
MsgBox Err.Number & vbCrLf & Err.Description
gblStopProcessing = True
Resume HandleExit
End Sub
Sub ParseBlockingSessionsEmailPartTwo()
Dim vPrevChar10 As Integer
Dim vNextChar10 As Integer
Dim vCounter As Integer
Dim vLastEmail As Long
Dim vEmailBody As String
Dim vRowsInEmail As Integer
Dim vRecordCounter As Integer
Application.ScreenUpdating = True
Application.StatusBar = "Emails imported. Working on parsing the data therein."
Application.ScreenUpdating = False
Sheets("Merge Data").Select
Columns("B:B").Select 'Following gets rid of the email body content that comes prior to the data table
Selection.Replace What:="Blocking Sessions Check" & Chr(32) & Chr(13) & Chr(10) & Chr(13) & Chr(10) & Chr(13) & Chr(10), Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
vCounter = 1
vNextChar10 = 0
vRecordCounter = 1
With ActiveSheet
vLastEmail = .Cells(.Rows.Count, "B").End(xlUp).Row 'Last row in Column-B
End With
For vRecordCounter = 2 To vLastEmail 'Performs internal operation, one row per email, starting at B2.
Range("B" & vRecordCounter).Select
vEmailBody = ActiveCell.Value
vRowsInEmail = Len(vEmailBody) - Len(Replace(vEmailBody, Chr(10), "")) + 1 'Counts the number of line returns in the email body and adds one to get the rows in the body
With Range("B" & vRecordCounter & ":B" & vRecordCounter)
For vCounter = 1 To vRowsInEmail 'Will add a column to each row for each line in the email body
vPrevChar10 = vNextChar10 + 1
vNextChar10 = InStr(vPrevChar10, ActiveCell.Value, Chr(10))
.Offset(, vCounter + 1) = "=IFERROR(MID($B" & vRecordCounter & "," & vPrevChar10 & "," & vNextChar10 - vPrevChar10 + 0 & "), RIGHT($B" & vRecordCounter & ", LEN($B" & vRecordCounter & ") - " & vPrevChar10 - 1 & "))"
Next
End With
Next
' Call ParseBlockingSessionsEmailPartThree
End Sub
Sub ParseBlockingSessionsEmailPartThree()
Dim vmdLastEmail As Long
Dim vmdRow As Integer
Dim vdRowA As Integer
Dim vdRowB As Integer
Application.ScreenUpdating = True
Application.StatusBar = "Emails imported. Data parsed. Working on formatting the data."
Application.ScreenUpdating = False
vmdRow = 2
'While in Merge Data worksheet
Sheets("Sheet1").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:C").Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
With ActiveSheet
vmdLastEmail = .Cells(.Rows.Count, "B").End(xlUp).Row 'Last row in Column-B of Merge Data worksheet
End With
'While in Merge Data worksheet
For vmdRow = 2 To vmdLastEmail
Sheets("Merge Data").Select
Range("B" & vmdRow).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'While in Data worksheet
Sheets("Data").Select
Range("A1").Select
With ActiveSheet
vdRowA = .Cells(.Rows.Count, "A").End(xlUp).Row 'Last row in Column-A of Merge Data worksheet
End With
Range("B1").Select
With ActiveSheet
vdRowB = .Cells(.Rows.Count, "B").End(xlUp).Row 'Last row in Column-B of Merge Data worksheet
End With
Range("B" & vdRowB).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
With ActiveSheet
vdRowB = .Cells(.Rows.Count, "B").End(xlUp).Row 'NEW last row in Column-B
End With
'Back to Merge Data worksheet
Sheets("Sheet1").Select
Range("A" & vmdRow).Select
Selection.Copy
'Back to Data worksheet
Sheets("Data").Select
Range("A" & vdRowA & ":A" & vdRowB).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next
Range("A2").Select
'Wrap it up
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "EMAIL_DATE-TIME"
Range("B1").Select
ActiveCell.FormulaR1C1 = "BLOCKING-SESSION-RECORD"
Range("A1:B1").Select
Selection.Font.Bold = True
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
Application.StatusBar = "All done. Emails imported, data parsed and formatted (a little)."
MsgBox "All done. Have fun."
ActiveWindow.FreezePanes = True
Cells.Select
Selection.Columns.AutoFit
Range("C1").Select
End Sub