SerenityNetworks
Board Regular
- Joined
- Aug 13, 2009
- Messages
- 131
- Office Version
- 365
- Platform
- Windows
I'm not a coder, but I'm trying to merge a couple bits of VBA I've found in order to copy the body of emails in a directory into Excel. The code is below.
Really, all I need is:
To be more specific, the body of the email will always contain a single line of text followed by a seven column table that is n rows (where n is at least 2 and is never greater than 50). The table has a header row and then n data rows. The data rows in the table may have line breaks within a given cell. (Note: If I 'select all' in the message body, copy, and then paste into Excel, it parses into the worksheet's cells perfectly.)
Ideally I'd like the date/time stamp in Column-A then the header items in Columns B through H, with the data rows from the table following in Columns B through H and the date/time stamp repeating for each of the data rows. However, I'll take it as I can get it. Simply putting the timestamp in a cell, copy/pasting the body content below, and then repeating for all the emails would be perfectly fine. The data provided in the "Audit" worksheet created in the code below is nice, but not required.
Whether it is tweaking the code below or something entirely new, I don't care. I will greatly appreciate any help with the task.
Thanks in advance,
Andrew
Really, all I need is:
- The date/time stamp of the email.
- The body of the email.
- From a specified Outlook folder.
To be more specific, the body of the email will always contain a single line of text followed by a seven column table that is n rows (where n is at least 2 and is never greater than 50). The table has a header row and then n data rows. The data rows in the table may have line breaks within a given cell. (Note: If I 'select all' in the message body, copy, and then paste into Excel, it parses into the worksheet's cells perfectly.)
Ideally I'd like the date/time stamp in Column-A then the header items in Columns B through H, with the data rows from the table following in Columns B through H and the date/time stamp repeating for each of the data rows. However, I'll take it as I can get it. Simply putting the timestamp in a cell, copy/pasting the body content below, and then repeating for all the emails would be perfectly fine. The data provided in the "Audit" worksheet created in the code below is nice, but not required.
Whether it is tweaking the code below or something entirely new, I don't care. I will greatly appreciate any help with the task.
Thanks in advance,
Andrew
Code:
Option Explicit
Public gblStopProcessing As Boolean
Sub ReadOutlookMessagesBody()
' requires Microsoft Outlook Object Library (Tools/References}
Dim wb As Workbook
Dim ws As Worksheet
Dim wsAudit As Worksheet
Dim wsControl As Worksheet
Dim objFolder As Object
Dim objMsg As Object
Dim objNSpace As Object
'
Dim objOutlook As Outlook.Application
'
Dim blRecordsHaveFormulas As Boolean
Dim blColourCell As Boolean
'
Dim Item As Variant 'MailItem
Dim Lines() As String
Dim xlRow As Long
Dim Keys
Dim xlSheet As Object 'Excel.Worksheet
Dim I As Long, J As Long, P As Long
'
Dim strDelimiter As String
Dim strText As String
Dim lngAuditRecord As Long
Dim lngKount As Long
Dim lngRecordsInEmail As Long
Dim lngRow As Long
Dim lngSaveType As Long ' olTXT save type
Dim lngTotalItems As Long
Dim lngTotalRecords As Long
Dim intFormulasEndColumn As Integer
Dim intFormulasStartColumn As Integer
Dim intFreefile As Integer
Dim intKount As Integer
'
On Error GoTo HandleError
'
' Initialise:
Set wb = ThisWorkbook
Set wsControl = wb.Worksheets("Control Sheet")
strDelimiter = wsControl.Range("B3").Value
blColourCell = False
lngAuditRecord = 1 ' Start row
lngSaveType = 0 ' save as .txt
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("Merge Data").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"
wb.Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wsAudit = ActiveSheet
wsAudit.Name = "Audit"
wsAudit.Range("A1") = "Email data imported on " & Now()
lngAuditRecord = lngAuditRecord + 1
wsAudit.Cells(lngAuditRecord, 1) = "Subject"
wsAudit.Cells(lngAuditRecord, 2) = "Sender's Email Address"
wsAudit.Cells(lngAuditRecord, 3) = "Email Creation Time"
wsAudit.Cells(lngAuditRecord, 4) = "Email Received Time"
wsAudit.Cells(lngAuditRecord, 5) = "Records Imported"
wsAudit.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
Selection.EntireRow.Font.Bold = True
Selection.HorizontalAlignment = xlCenter
lngAuditRecord = lngAuditRecord + 1
ws.Activate
lngRow = 1 ' start row in worksheet "Merge Data"
For lngKount = 1 To lngTotalItems
If Item.subject Like "Sessions Check - SRTACP01" Then
'Get all lines from the mailbody
Lines = Split(Item.Body, vbCrLf) 'I WOULD BE PERFECTLY FINE WITH A SIMPLY COPY/PASTE HERE. I JUST DO NOT KNOW HOW TO DO IT.
'Next line in excel sheet
xlRow = xlRow + 1
xlSheet.Cells(xlRow, UBound(Keys) + 2) = Item.subject
'Visit all lines
For I = 0 To UBound(Lines)
'Search all keywords in each line
For J = 0 To UBound(Keys)
P = InStr(1, Lines(I), Keys(J), vbTextCompare)
If P > 0 Then
'Store the right part after the keyword
xlSheet.Cells(xlRow, J + 1) = Trim$(Mid$(Lines(I), P + Len(Keys(J)) + 1))
Exit For
End If
Next
Next
End If
' switch cell colouring: THIS IS HANDY, BUT NOT AT ALL REQUIRED
blColourCell = Not blColourCell
'
' Update Audit record: THIS IS NICE, BUT NOT AT ALL REQUIRED
On Error Resume Next
wsAudit.Activate
wsAudit.Cells(lngAuditRecord, 1) = objFolder.Items(lngKount).subject
wsAudit.Cells(lngAuditRecord, 2) = objFolder.Items(lngKount).SenderEmailAddress
wsAudit.Cells(lngAuditRecord, 3) = objFolder.Items(lngKount).CreationTime
wsAudit.Cells(lngAuditRecord, 4) = objFolder.Items(lngKount).ReceivedTime
wsAudit.Cells(lngAuditRecord, 5) = lngRecordsInEmail
wsAudit.Range("A1").Select
wsAudit.Cells.Columns.AutoFit
lngAuditRecord = lngAuditRecord + 1
On Error GoTo HandleError
'
ws.Activate
Next lngKount
'Kill ThisWorkbook.Path & "\temp3210.txt"
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
HandleExit:
On Error Resume Next
Application.ScreenUpdating = True
Set objNSpace = Nothing
Set objFolder = Nothing
Set objMsg = Nothing
Set objOutlook = Nothing
Set ws = Nothing
Set wsAudit = Nothing
Set wsControl = Nothing
Set wb = Nothing
'
If Not gblStopProcessing Then
MsgBox "Processing completed" & vbCrLf & vbCrLf & _
"Please check results", vbOKOnly + vbInformation, "Information"
End If
'
Exit Sub
'
HandleError:
MsgBox Err.Number & vbCrLf & Err.Description
gblStopProcessing = True
Resume HandleExit
End Sub
