Hello I am trying to extract a specific part of Email body and a count of how many emails with that same part I have got. I am using the below vba code but am getting the following issues:
Output is not populating however the script is running without fail.
unable to extract that specific part from the email body.
Code am using is:
Option Explicit
Sub Download_Outlook_Mail_To_Excel()
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer
Dim oRow As Integer
Dim MailBoxName As String
Dim Pst_Folder_Name As String
Const xlWorkbookName As String = "C:\Personal\Documents\Failures.xlsx" '// change as required
'// I'm using late binding in case you don't actually have a reference set.
Dim xlApp As Object
Dim xlWB As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open(xlWorkbookName)
MailBoxName = "ridutta#gmail.com"
Pst_Folder_Name = "SR Creation Failure" 'Sample "Inbox" or "Sent Items"
'To directly a Folder at a high level
'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)
'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder
Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If
'Read Through each Mail and export the details to Excel for Email Archival
xlWB.Sheets(1).Activate
Folder.Items.Sort "Received"
'Insert Column Headers
xlWB.Sheets(1).Cells(1, 1) = "Sender"
xlWB.Sheets(1).Cells(1, 2) = "Subject"
xlWB.Sheets(1).Cells(1, 3) = "Date"
xlWB.Sheets(1).Cells(1, 4) = "Size"
xlWB.Sheets(1).Cells(1, 5) = "EmailID"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"
'Export eMail Data from PST Folder
oRow = 1
For iRow = 1 To Folder.Items.Count
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
oRow = oRow + 1
xlWB.Sheets(1).Cells(oRow, 1).Select
xlWB.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
xlWB.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
xlWB.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
xlWB.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
xlWB.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing
xlWB.Close False
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing
End_Lbl1:
End Sub
Use a regular expression to extract the part of the email body you are looking for. Refer to this: How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops
Related
I extract data from Outlook email into Excel. The data is not extracted in sequence based on date and time.
The date format in my computer is ddmmyyyy format and the time zone is UK.
I want the date to be in one column and the time to be in another column.
Also I want to extract the email from sender email jkcopy#gmail.com.
Sub GetMailInfo()
Dim results() As String
' get contacts
results = ExportEmails(True)
' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results
MsgBox "Completed"
End Sub
Function ExportEmails(Optional headerRow As Boolean = False) As String()
Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer
' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select
Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items
' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If
numRows = mailFolderItems.Count
' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)
If IsMail(folderItem) Then
Set msg = folderItem
End If
With msg
tempString(i + startRow, 1) = .SenderName
tempString(i + startRow, 2) = .ReceivedTime
tempString(i + startRow, 3) = .Subject
'tempString(i + startRow, 4) = Left$(.Body, 200) ' throws error without limit
'tempString(i + startRow, 5) = .SenderEmailAddress
'tempString(i + startRow, 6) = .SentOn
End With
' adding file attachment names where they exist - added by JP
If msg.Attachments.Count > 50 Then
For jAttach = 1 To msg.Attachments.Count
tempString(i + startRow, 39 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
Next jAttach
End If
Next i
' first row of array should be header values
If headerRow Then
tempString(1, 1) = "SenderName"
tempString(1, 2) = "ReceivedTime"
tempString(1, 3) = "subject"
'tempString(1, 4) = "Body"
'tempString(1, 5) = "SenderEmailAddress"
'tempString(1, 6) = "SentOn"
End If
ExportEmails = tempString
' apply pane freeze and filtering
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
You need to sort the items collections before iterating over all entries. The Items.Sort method sorts the collection of items by the specified property. The index for the collection is reset to 1 upon completion of this method.
The MailItem.ReceivedTime
which returns a Date indicating the date and time at which the item was received property can be used for sorting items in the folder.
mailFolderItems.Sort "[ReceivedTime]", False
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)
Use the FormatDateTime function which returns an expression formatted as a date or time for your cells/rows.
The date/time format does not matter as long as you are adding the data as the DateTime type, not as a string (you do that part correctly).
If you want a particular order, you can either resort the data later in Excel, or you can sort the Items collection first by calling Items.Sort
Set mailFolderItems = strFolderName.Items
mailFolderItems.Sort "[ReceivedTime]", false
I have trying to send emails to a list of address and add the entire pdfs in a folder,
the code works the problem i have is that the files can be add only if i put a full path.
I want it to go to D and get all the pdfs or files from the folder and create email.
so again everything works except the attachments need a full path, but i just want to put the path of the folder and it will take all the files from it,
thank you.
Sub massemailsend()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A1:A70")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.Subject = cell.Offset(0, 1).Value
.Body = cell.Offset(0, 2).Value
'\\Attacment from here
.Attachments.Add cell.Offset(0, 3).Value
.Display
End With
Set objMail = Nothing
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
I always use this function, returning an array of all filenames matching your spec. You can super easily integrate that in your code.
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
'Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Function comes from http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/
If the path is always the same, define it at the top like this (include the trailing backslash)
Const myPath = "D:\FilesAreHere\"
Then change the attachment line to this:
.Attachments.Add myPath & cell.Offset(0, 3).Value
I have designed a VBA code to retrieve the list of mails from the inbox of your outlook using the link Retrieve maillist from outlook
Here there is a line of code
ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
which specifies to get senders email Address but when it is stored in excel it shows as below
/O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=WIPRO365.ONMICROSOFT.COM-52823-C1374FA5
I would like to see it as knowledge#wipro.com mean to say in the proper email format. How to avail this option? Should I do changes at VBA code or excel.
I have tried this in many blogs still vain. Any suggestions will be helpful.
Firstly, this is multiple dot notation take to its extreme - Folder.Items.Item(iRow). This is a really bad idea, especially in a loop - each "." forces Outlook to create and return a brand new COM object. Cache Folder.Items before entering the loop, and retrieve MailItem using Items.Item(I) only once at the beginning of the loop.
That being said, what you get is a perfectly valid EX type address. Check the MailItem.SenderEmailType property first. If it is "EX", use MailItem.Sender.GetExchangeUser.PrimarySmtpAddress (be prepared to handle nulls). Otherwise just use MailItem.SenderEmailAddress property.
Have a look here for how to look at the Global Address Book
Outlook 2010 GAL with Excel VBA
Here is a very simple implementation that converts to the smtp address for Exchange accounts.
Option Explicit
Dim appOL As Object
Dim oGAL As Object
Dim i
Dim oContact
Dim oUser
Dim UserIndex
Dim arrUsers(1 To 65000, 2) As String
Sub test()
End Sub
Sub Download_Outlook_Mail_To_Excel()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Dim folders As Outlook.folders
Dim folder As Outlook.MAPIFolder
Dim iRow As Integer
Dim Pst_Folder_Name
Dim MailboxName
Set appOL = CreateObject("Outlook.Application")
'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailboxName = "your email address"
'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Inbox"
Set folder = Outlook.Session.folders(MailboxName).folders(Pst_Folder_Name)
If folder = "" Then
MsgBox "Invalid Data in Input"
GoTo end_lbl1:
End If
'Rad Through each Mail and export the details to Excel for Email Archival
Sheets(1).Activate
Dim mail As Outlook.MailItem
Dim oAccount As Outlook.Account
Dim stringAddress
FillAddress
For iRow = 1 To folder.Items.Count
If folder.Items.Item(iRow).Class = olMail Then
Set mail = folder.Items.Item(iRow)
Sheets(1).Cells(iRow, 1).Select
Sheets(1).Cells(iRow, 1) = mail.SenderName
Sheets(1).Cells(iRow, 2) = mail.Subject
Sheets(1).Cells(iRow, 3) = mail.ReceivedTime
Sheets(1).Cells(iRow, 4) = mail.Size
Select Case mail.SenderEmailType
Case "SMTP"
Sheets(1).Cells(iRow, 5) = mail.SenderEmailAddress
Case "EX"
'Set oAccount = Outlook.
stringAddress = FindAddress(mail.SenderEmailAddress)
Sheets(1).Cells(iRow, 5) = stringAddress
End Select
End If
'Set oAccount = mail.SenderEmailAddress
'Sheets(1).Cells(iRow, 6) = Folder.Items.Item(iRow).Body
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
end_lbl1:
End Sub
Function FindAddress(strAddress)
Dim address As String
For i = 1 To 65000
If UCase(arrUsers(i, 0)) = strAddress Then
address = arrUsers(i, 2)
Exit For
End If
Next
FindAddress = address
End Function
Sub FillAddress()
Set oGAL = appOL.GetNamespace("MAPI").AddressLists("Global Address List").AddressEntries
For i = 1 To oGAL.Count
Set oContact = oGAL.Item(i)
If oContact.AddressEntryUserType = 0 Then
Set oUser = oContact.GetExchangeUser
If Len(oUser.LastName) > 0 Then
UserIndex = UserIndex + 1
arrUsers(UserIndex, 0) = oUser.address
arrUsers(UserIndex, 1) = oUser.Name
arrUsers(UserIndex, 2) = oUser.PrimarySmtpAddress
End If
End If
Next i
End Sub
I found this code, but list file names sorted by name and I don't know how to adapt it:
Dim MyPathAs String
Dim MyNameAs String
With Dialogs(wdDialogCopyFile)
If .Display() <> -1 Then Exit Sub
MyPath = .Directory
End With
If Len(MyPath) = 0 Then Exit Sub
If Asc(MyPath) = 34 Then
MyPath = Mid$(MyPath, 2, Len(MyPath) - 2)
End If
MyName = Dir$(MyPath& "*.*")
Do While MyName<> ""
Selection.InsertAfterMyName&vbCr
MyName = Dir
Loop
Selection.CollapsewdCollapseEnd
End Sub
Here's a different way to do it. In Word VBA editor:
Tools > References... > checkmark both of:
Microsoft Scripting Runtime
Microsoft Excel Object Library
Then:
Dim iFil As Long
Dim FSO As FileSystemObject
Dim fil As File
Dim fld As Folder
Dim xlApp As Excel.Application
Dim sh As Excel.Worksheet
Dim rngTableTopLeft As Excel.Range
Set xlApp = New Excel.Application
Set sh = xlApp.Workbooks.Add.Sheets(1)
Set rngTableTopLeft = sh.Range("A1") ' or wherever; doesn't matter
'Put file names and date last modified in Excel sheet
Set FSO = New FileSystemObject
Set fld = FSO.GetFolder("C:\Users\jeacor\Documents")
For Each fil In fld.Files
iFil = iFil + 1
With rngTableTopLeft.Cells(iFil, 1)
.Value = fil.Name
.Offset(0, 1).Value = fil.DateLastModified
End With
Next fil
'Sort them by date last modified using Excel Sort function
With sh.Sort
.SortFields.Add Key:=rngTableTopLeft.Offset(0, 1).Resize(fld.Files.Count, 1), Order:=xlAscending
.SetRange rngTableTopLeft.Resize(fld.Files.Count, 2)
.Apply
End With
'Copy result to Word document
With rngTableTopLeft.Resize(fld.Files.Count, 2)
.EntireColumn.AutoFit
.Copy
End With
Selection.Paste
'Goodbye
xlApp.DisplayAlerts = False 'suppress the "exit without saving?" prompt
xlApp.Quit
I am using VBA in Outlook to extract mail information from items in the mainfolder and subfolder. The mainfolder failed to set(capture) the subfolder properties into it and it causes the runtime error.
The runtime error differs whenever I run. For example, sometime I received -970718969 (c6240107) and another time I received -2044460793 (86240107).
When I clicked debug, it points to this line of code:
For Each itm In subFld.Items
Here is the screenshot:
Here is the full code:
Public monthValue As Integer
Public yearValue As String
'Ensure Microsoft Excel 11.0 Object Library is ticked in tools.
Sub ExportToExcel1()
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 strPath As String
Dim intRowCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim mainFld As Outlook.MAPIFolder
Dim subFld As Outlook.MAPIFolder
Dim itm As Object
Dim offsetRow As Long
Dim emailCount As Long
'Set the path of the excel file.
strSheet = "For fun.xlsx"
strPath = "C:\Users\xxxxxx\Desktop\xxxxx\"
strSheet = strPath & strSheet
Debug.Print strSheet
Set nms = Application.GetNamespace("MAPI")
Set mainFld = nms.PickFolder 'Open the box to select the file.
'Handle potential errors with Select Folder dialog box.
If mainFld Is Nothing Then
MsgBox "Thank you for using this service.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.DefaultItemType <> olMailItem Then
MsgBox "Please select the correct folder.", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
ElseIf mainFld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
mainForm.Show
'If user clicks cancel, it will exit sub.
If yearValue = "" Then
Set nms = Nothing
Set mainFld = Nothing
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True 'Show my workbook.
'Check if there are any subfolders.
If mainFld.Folders.Count = 0 Then '1
'No subfolder.
For Each itm In mainFld.Items
If itm.Class <> olMail Then '2
'do nothing
Else
Set msg = itm
'Validate the month and year for the email.
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '3
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount 'Track the number of email.
Else
'Do nothing
End If '3
End If '2
Next itm
Else
'With subfolder
For Each itm In mainFld.Items
If itm.Class <> olMail Then '4
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '5
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '5
End If '4
Next itm
For Each subFld In mainFld.Folders
For Each itm In subFld.Items
If itm.Class <> olMail Then '6
'do nothing
Else
Set msg = itm
If Month(msg.ReceivedTime) = monthValue And Year(msg.ReceivedTime) = yearValue Then '7
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
intRowCounter = 1 + offsetRow
Set rng = wks.Cells(intRowCounter, 1)
rng.Value = msg.ReceivedTime
Set rng = wks.Cells(intRowCounter, 2)
rng.Value = msg.SentOn
Set rng = wks.Cells(intRowCounter, 3)
rng.Value = msg.Subject
emailCount = 1 + emailCount
Else
'Do nothing
End If '7
End If '6
Next itm
Next subFld
End If '1
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
'Inform the user that there are no email.
If emailCount = 0 Then
MsgBox "No emails associated with this date: " & MonthName(monthValue, True) & " " & yearValue, vbOKOnly, "No Emails"
End If
Exit Sub
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set mainFld = Nothing
Set subFld = Nothing
Set itm = Nothing
End Sub
Do you get that error immediately or only after processing a large number of items? Most likely you are opening too many items and run out of RPC channels. Is this a cached or an online Exchange profile?
Instead of looping through all items, use the Table object (MAPITable.GetTable) - if nothing else, it will be a lot faster.
EDIT: If you are using Exchange, every store object (message, folder, store) opens an RPC channel. Exchange Server limits the number of RPC channels to 255 per client (can be changed on the server). Do not use "for each" loop (it keeps all items referenced until the loop ends) and avoid multiple dot notation (because you will have implicit variables that you cannot explicitly dereference). You will also need to release all Outlook objects as soon as you are done with them.
set fldItems = mainFld.Items
For i = 1 to fldItems.Count do
set itm = fldItems.Item(i)
'do stuff
set itm = Nothing
next
As for the Table object (introduced in Outlook 2007), see http://msdn.microsoft.com/en-us/library/office/ff860769.aspx. If you need to use this in an earlier version of Outlook, you can use the MAPITable object in Redemption (I am its author); it also has a MAPITable.ExecSQL method that takes a standard SQL query and returns the ADODB.Recordset object.