How to extract Outlook email data from a specific sender in date and time sequence? - vba

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

Related

OutLook VBA Email or Notification Causes Out of Bounds Error

I have some outlook VBA code which works fine to save attachments, however every time I get an email or a meeting notification in Outlook it causes an instant Out of Bounds error If I don't get any emails or notifications the code will run fine through to completion.
Is there a way to ensure that these notifications will not stop the code from running?
Option Explicit
Sub SaveAttachmentsFromSelectedItemsPDF2_ForNext()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
Dim i As Long
Dim j As Long
saveToFolder = "c:\dev\outlookexport" 'change the path accordingly
savedFileCountPDF = 0
For i = 1 To ActiveExplorer.Selection.Count
Set currentItem = ActiveExplorer.Selection(i)
For j = 1 To currentItem.Attachments.Count
Set currentAttachment = currentItem.Attachments(j)
If UCase(Right(currentAttachment.DisplayName, 5)) = UCase(".xlsx") Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 5) & ".xlsx"
savedFileCountPDF = savedFileCountPDF + 1
End If
' If For Next does not release memory automatically then
' uncomment to see if this has an impact
'Set currentAttachment = Nothing
Next
' If For Next does not release memory automatically then
' uncomment to see if this has an impact
'Set currentItem = Nothing
Next
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub
This is what I tried to create from the answer below:
Option Explicit
Sub SaveAttachmentsFromSelectedItemsPDF2_ForNext()
Dim currentItem As Object
Dim currentAttachment As Attachment
Dim saveToFolder As String
Dim savedFileCountPDF As Long
Dim i As Long
Dim j As Long
Dim x As Long
Dim myOlExp As Object
Dim myOlSel As Object
' New
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
saveToFolder = "c:\dev\outlookexport" 'change the path accordingly
savedFileCountPDF = 0
For x = 1 To myOlSel.Count
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
Set currentItem = ActiveExplorer.Selection(i)
For j = 1 To currentItem.Attachments.Count
Set currentAttachment = currentItem.Attachments(j)
If UCase(Right(currentAttachment.DisplayName, 5)) = UCase(".xlsx") Then
currentAttachment.SaveAsFile saveToFolder & "\" & _
Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 5) & ".xlsx"
savedFileCountPDF = savedFileCountPDF + 1
End If
Next
End If
Next
MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation
End Sub
The Selection property of the Explorer class returns a Selection object that contains the item or items that are selected in the explorer window. In your code I've noticed the following lines of code:
For i = 1 To ActiveExplorer.Selection.Count
Set currentItem = ActiveExplorer.Selection(i)
So, if the selection is changed in Outlook between these two lines of code you may get out of range exception at runtime. Instead, I'd recommend caching the selection object and use it through the code to make sure it remains the same:
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
' do something here
End If
Next
Another important thing is that a folder may contain different types of items. You'd need to check their message class to distinguish different kind of Outlook items.

Excel VBA - Copy comma seperated sentence from emails to seperate Excel cells

I am trying to include a line in an Excel VBA script which identified all the text in a sentence that appears after the occurance of "Keyword:" in the body of multiple emails and copies each comma separated word into separate Excel cells. The phrases could be anything, always a single word but can't be predefined. For example, the email contained a line like:
Keyword: phrase1, phrase2, phrase3, phrase4
The result, in Excel:
First email: A1 phrase1 B1 phrase2 etc.
Second email: A2 phrase1 B2 phrase2 etc.
I've tried to use something like the following but don't know where to go from there:
CreateObject("VBScript.RegExp").Pattern = "((Keyword:)\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*))"
Here's what I have so far:
Option Compare Text
Sub Count_Emails()
Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oFoldToSearch As Object
Dim intCounter As Integer
Dim oWS As Worksheet
Dim dStartDate, dEnddate As Date
Set oWS = Sheets("Sheet1")
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
intCounter = 1
dStartDate = oWS.Range("A1").Value
dEnddate = oWS.Range("B1").Value
Do
With oWS
If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
oItems(intCounter).Subject Like "*Keyword:*" Then
'Something needs to happen here? A VBScript.RegExp.Pattern maybe?
End If
End With
intCounter = intCounter + 1
Loop Until intCounter >= oItems.Count + 1
Set oNS = Nothing
Set oTaskFolder = Nothing
Set oItems = Nothing
End Sub
EDIT: To clarify that the phrases are not pre-defined, they could be anything.
EDIT2: To clarify that the body of the emails contains "Keyword:" followed by comma separated single words that are to be copied each into their own Excel cell.
Here I iterate over an array of phrases using instr to find the position of the phase in the mail item's subject. If the position in greater then 0 I use it to calculate the potion of the subject to write to the worksheet.
Count_Emails uses a ParamArray to accept up to 29 arguments in VBA 2003 or earlier and up to 60 arguments in VBA 2007 or later.
For Example if you only wanted to search for a single phrase:
NumberOfEmails = Count_Emails( "Phrase1" )
On the other hand if your had three phrases you need to search for, just add them as additional arguments
NumberOfEmails = Count_Emails( "Phrase1", "Phrase2", "Phrase3" )
Option Explicit
Option Compare Text
Function Count_Emails(ParamArray Phrases())
Dim Count as Long
Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim phrase As Variant
Dim item As Object, oFoldToSearch As Object
Dim StartDate, EndDate As Date, MailDate As Date
Dim PhraseSize As Long, pos As Long
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
With Sheets("Sheet1")
StartDate = .Range("A1").Value
EndDate = .Range("B1").Value
For Each item In oItems
MailDate = DateValue(item.ReceivedTime)
If MailDate >= StartDate And MailDate <= EndDate Then
For Each phrase In Phrases
pos = InStr(item.Subject, phrase)
If pos > 0 Then
With .Range("C" & Rows.Count).End(xlUp).Offset(1)
PhraseSize = Len(phrase)
.Value = Right(item.Subject, Len(item.Subject) - pos - PhraseSize + 1)
End With
Count = Count + 1
Exit For
End If
Next
End If
Next
End With
Set oNS = Nothing
Set oTaskFolder = Nothing
Set oItems = Nothing
Count_Emails = Count
End Function
Sub ExtractKeyWords(text As String)
Dim loc As Long
Dim s As String
Dim KeyWords
Dim Target As Range
loc = InStr(text, "Keyword:")
If loc > 0 Then
s = Trim(Right(text, Len(text) - loc - Len("Keyword:") + 1))
KeyWords = Split(s, ",")
With Worksheets("Sheet1")
If .Cells(1, .Columns.Count).End(xlToLeft) = "" Then
Set Target = .Cells(1, .Columns.Count).End(xlToLeft)
Else
Set Target = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1)
End If
Target.Resize(UBound(KeyWords) + 1).Value = Application.Transpose(KeyWords)
End With
End If
End Sub
if I correctly get your aim (see comments) you could modify your code as follows:
Option Explicit
Option Compare Text
Sub Count_Emails()
Dim oNS As Outlook.NameSpace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim keyword As Variant
Dim item As Object, oFoldToSearch As Object
Dim StartDate, EndDate As Date, MailDate As Date
Dim pos As Long
Dim xlApp As Excel.Application '<--| early binding ==> add your project the reference to Microsoft Excel XX.Y Object library
Dim phrasesArr As Variant
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
Set xlApp = GetExcel(True) '<--| get running instance of excel application
If xlApp Is Nothing Then
MsgBox "No Excel running instance", vbCritical + vbInformation
Exit Sub
End If
With xlApp.Sheets("Sheet1") '<--| this assumes that the running instance of excel has an open workbook with a sheet named "Sheet1"
StartDate = .Range("A1").Value
EndDate = .Range("B1").Value
For Each item In oItems
MailDate = DateValue(item.ReceivedTime)
If MailDate >= StartDate And MailDate <= EndDate Then
pos = InStr(item.Subject, "Keyword:") '<--| search for "Keyword:" in current mail subject
If pos > 0 Then '<--| if found...
phrasesArr = Split(Right(item.Subject, Leng(item.Subject) - pos - Len("keyword:")), ",") '<-- fill an array with "phrases" separated by commas after "keyword:"
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Resize(, UBound(phrasesArr) + 1).Value = phrasesArr '<--| write "phrases" in column "C" first non empty cell and its adjacent cells
End If
End If
Next
End With
Set xlApp = Nothing
Set oItems = Nothing
Set oFoldToSearch = Nothing
Set oTaskFolder = Nothing
Set oNS = Nothing
End Sub
Function GetExcel(Optional mustBeCurrent As Variant) As Excel.Application
Dim excelApp As Excel.Application
If IsMissing(mustBeCurrent) Then mustBeCurrent = False '<--| default is get an Excel object "at any cost", if it's not running then create it
On Error Resume Next
Set GetExcel = GetObject(, "Excel.Application") '<--| try getting a running Excel application
On Error GoTo 0
If GetExcel Is Nothing Then If Not mustBeCurrent Then Set GetExcel = CreateObject("Excel.Application") '<--| if no running instance of Excel has been found then open a new one
End Function

Extract partail email body from Outlook to Excel

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

VBA Run-Time Error '-2147221233 (8004010f)'

I am attempting to run the VBA code mentioned below.
The VBA code is for pulling email information from a single folder of the user's selection in Microsoft Outlook and listing what the response time is in Microsoft Excel.
Here is the error message I receive when I attempt to run it.
"Run-time error '-2147221233 (8004010f)':
The Property "http://schemas.microsoft.com/mapi/proptag/0x003F0102" is unknown or cannot be found.
Here is the code I am using:
Option Explicit
Public ns As Outlook.Namespace
Private Const EXCHIVERB_REPLYTOSENDER = 102
Private Const EXCHIVERB_REPLYTOALL = 103
Private Const EXCHIVERB_FORWARD = 104
Private Const PR_LAST_VERB_EXECUTED = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
Private Const PR_LAST_VERB_EXECUTION_TIME = "http://schemas.microsoft.com/mapi/proptag/0x10820040"
Private Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Private Const PR_RECEIVED_BY_ENTRYID As String = "http://schemas.microsoft.com/mapi/proptag/0x003F0102"
' Locates best matching reply in related conversation to the given mail message passed in as oMailItem
Private Function GetReply(oMailItem As MailItem) As MailItem
Dim conItem As Outlook.Conversation
Dim ConTable As Outlook.Table
Dim ConArray() As Variant
Dim MsgItem As MailItem
Dim lp As Long
Dim LastVerb As Long
Dim VerbTime As Date
Dim Clockdrift As Long
Dim OriginatorID As String
Set conItem = oMailItem.GetConversation ' Let Outlook and Exchange do the hard lifting to get entire converstion for email being checked.
OriginatorID = oMailItem.PropertyAccessor.BinaryToString(oMailItem.PropertyAccessor.GetProperty(PR_RECEIVED_BY_ENTRYID))
If Not conItem Is Nothing Then ' we have a conversation in which we should be able to match the reply
Set ConTable = conItem.GetTable
ConArray = ConTable.GetArray(ConTable.GetRowCount)
LastVerb = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTED)
Select Case LastVerb
Case EXCHIVERB_REPLYTOSENDER, EXCHIVERB_REPLYTOALL ', EXCHIVERB_FORWARD ' not interested in forwarded messages
VerbTime = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTION_TIME)
VerbTime = oMailItem.PropertyAccessor.UTCToLocalTime(VerbTime) ' convert to local time
' Debug.Print "Reply to " & oMailItem.Subject & " sent on (local time): " & VerbTime
For lp = 0 To UBound(ConArray)
If ConArray(lp, 4) = "IPM.Note" Then ' it is a mailitem
Set MsgItem = ns.GetItemFromID(ConArray(lp, 0)) 'mail item to check against
If Not MsgItem.Sender Is Nothing Then
If OriginatorID = MsgItem.Sender.ID Then
Clockdrift = DateDiff("s", VerbTime, MsgItem.SentOn)
If Clockdrift >= 0 And Clockdrift < 300 Then ' Allow for a clock drift of up to 300 seconds. This may be overgenerous
Set GetReply = MsgItem
Exit For ' only interested in first matching reply
End If
End If
End If
End If
Next
Case Else
End Select
End If
' as we exit function GetMsg is either Nothing or the reply we are interested in
End Function
Public Sub ListIt()
Dim myOlApp As New Outlook.Application
Dim myItem As Object ' item may not necessarily be a mailitem
Dim myReplyItem As Outlook.MailItem
Dim myFolder As Folder
Dim xlRow As Long
Set ns = myOlApp.GetNamespace("MAPI") ' Initialise Outlook access
Set myFolder = ns.PickFolder() ' for the sake of this example we just pick a folder.
InitSheet ActiveSheet ' initialise the spreadsheet
xlRow = 3
For Each myItem In myFolder.Items
If myItem.Class = olMail Then
Set myReplyItem = GetReply(myItem) ' this example only deals with mailitems
If Not myReplyItem Is Nothing Then ' we found a reply
PopulateSheet ActiveSheet, myItem, myReplyItem, xlRow
xlRow = xlRow + 1
End If
End If
DoEvents ' cheap and nasty way to allow other things to happen
Next
MsgBox "Done"
End Sub
Private Sub InitSheet(mySheet As Worksheet)
With mySheet
.Cells.Clear
.Cells(1, 1).FormulaR1C1 = "Received"
.Cells(2, 1).FormulaR1C1 = "From"
.Cells(2, 2).FormulaR1C1 = "Subject"
.Cells(2, 3).FormulaR1C1 = "Date/Time"
.Cells(1, 4).FormulaR1C1 = "Replied"
.Cells(2, 4).FormulaR1C1 = "From"
.Cells(2, 5).FormulaR1C1 = "To"
.Cells(2, 6).FormulaR1C1 = "Subject"
.Cells(2, 7).FormulaR1C1 = "Date/Time"
.Cells(2, 8).FormulaR1C1 = "Response Time"
End With
End Sub
Private Sub PopulateSheet(mySheet As Worksheet, myItem As MailItem, myReplyItem As MailItem, xlRow As Long)
Dim recips() As String
Dim myRecipient As Outlook.Recipient
Dim lp As Long
With mySheet
.Cells(xlRow, 1).FormulaR1C1 = myItem.SenderEmailAddress
.Cells(xlRow, 2).FormulaR1C1 = myItem.Subject
.Cells(xlRow, 3).FormulaR1C1 = myItem.ReceivedTime
'.Cells(xlRow, 4).FormulaR1C1 = myReplyItem.SenderEmailAddress
.Cells(xlRow, 4).FormulaR1C1 = myReplyItem.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) ' I prefer to see the SMTP address
For lp = 0 To myReplyItem.Recipients.Count - 1
ReDim Preserve recips(lp) As String
recips(lp) = myReplyItem.Recipients(lp + 1).Address
Next
.Cells(xlRow, 5).FormulaR1C1 = Join(recips, vbCrLf)
.Cells(xlRow, 6).FormulaR1C1 = myReplyItem.Subject
.Cells(xlRow, 7).FormulaR1C1 = myReplyItem.SentOn
.Cells(xlRow, 8).FormulaR1C1 = "=RC[-1]-RC[-5]"
.Cells(xlRow, 8).NumberFormat = "[h]:mm:ss"
End With
End Sub
Can you help me out? Please let me know if I could be any more specific.
I noticed that the error occurs on the only line using the "as string" in the declaration. Although this type of declaration if perfectly fine in VB, it doesn't work in VBA.
Simply remove the "as string" on that line.

Counting emails using excel VBA

First time posting - hopefully I am clear enough.
I'm not that expirienced with excel VBA, but have managed to find and change (with the help of my IT area) some code through these forums that counts the number of emails in outlook folders by a date in a cell. The code works fine when counting emails in one folder. What I need the code to do is count the emails in numerous folders (of which the list is stored in a sheet in the workbook) and output the count into seperate columns. (was hoping to post a picture as an example but I need a higher rep!)
Here is the code I have so far:
Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer, DateCount As Integer, iCount As Integer
Dim myDate As Date
Dim myCell As Object
Dim dictEmailDates As New Scripting.Dictionary
Dim folder1 As String, folder2 As String, folder3 As String
folder1 = Sheets("Sheet1").Cells.Cells(2, 5)
folder2 = Sheets("Sheet1").Cells.Cells(2, 6)
folder3 = Sheets("Sheet1").Cells.Cells(2, 7)
' Get Outlook Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders(folder1)
If Not IsEmpty(folder2) Then
Set objFolder = objFolder.Folders(folder2)
End If
If Not IsEmpty(folder3) Then
Set objFolder = objFolder.Folders(folder3)
End If
If Err.Number <> 0 Then
Err.Clear
MsgBox "Folder doesn't exist. Please ensure you have input the correct folder details."
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
Exit Sub
End If
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
CountEmails objFolder, dictEmailDates
' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
' Count the emails dates equal to active cell
Sheets("Sheet1").Range("A2").Select
Do Until IsEmpty(ActiveCell)
DateCount = 0
myDate = ActiveCell.Value
If dictEmailDates.Exists(myDate) Then
DateCount = dictEmailDates(myDate)
End If
Selection.Offset(0, 1).Activate
ActiveCell.Value = DateCount
Selection.Offset(1, -1).Activate
Loop
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub
Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
EmailCount = objFolder.Items.Count
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
If dictEmailDates.Exists(dateKey) Then
dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
Else
dictEmailDates.Add dateKey, 1
End If
End With
Next iCount
For iCount = 1 To FolderCount
CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub
Hoping someone can help?? If there is anything extra or if I need to explain myself more please let me know!
Cheers, Adrian
If I'm following, the issue is that folder1 (or 2 or 3) is the only folder being counted. The issue looks to be that you only ever load one folder into your dictionary (based on the code I would think it was folder3). I would address that by restructuring the code as follows (I also added some performance improvements and removed a bunch of stuff that looked to be doing nothing):
Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim myDate As Date
Dim dictEmailDates As New Scripting.Dictionary
Dim i As Integer
Dim dcell As Range 'refering to range saves you having to keep retyping range to use,
'reducing likelihood of typo
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'refering to ws saves having to type out
'Sheet1 each time, and also makes it easier to update code if sheet name ever changes
'Turn off screen updates for faster run
Application.ScreenUpdating = False
'Get the Outlook items setup
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
'Start looping through the folders
i = 0
Do Until IsEmpty(ws.Cells.Cells(2, 5 + i))
' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders(ws.Cells.Cells(2, 5 + i))
'Get count of items and put in array based on ReceivedTimes
CountEmails objFolder, dictEmailDates
Loop
'Notice I completely removed Date and Folder count from this sub, they were only ever
'set here, not used. Looked like legacy code from attempting to perform the count in
'this sub rather than the self-referencing sub you created.
' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
' Count the emails dates equal to current cell
i = 2
Set dcell = ws.Range("A" & i)
Do Until IsEmpty(dcell)
DateCount = 0
myDate = dcell.Value
If dictEmailDates.Exists(myDate) Then
DateCount = dictEmailDates(myDate)
End If
dcell.Offset(0, 1).Value = DateCount
i = i + 1
Set dcell = ws.Range("A" & i)
Loop
Application.ScreenUpdating = True
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub
Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
If dictEmailDates.Exists(dateKey) Then
dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
Else
dictEmailDates.Add dateKey, 1
End If
End With
Next iCount
For iCount = 1 To FolderCount
CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub