how to pull received time from all emails in outlook mailbox - vba

I have most of this worked out already, but need assistance. I want to store all of the received times of the emails from various outlook folders. All of the folders are inside the same folder so I have an array to go through each of these. I need the times stored into a variable that I can then display in or write.console. There will be hundreds of times to display. The variable is Totalmsg that I want these times stored in, then displayed once complete.
Sub EmailArrivalTimes()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim MailItem
Dim EmailCount() As Integer, arrNames
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
arrNames = Array ("Andrew", "Ashton", "Becca", "Beth", "Bree", "Brittany", "Cecilia", "Chance", "Christina J.", "Christine", "Dustin", "James", "Jeff", "Jenni", "Jennifer W.", "Josh", "Josie", "Kara", "Lisa", "Megan", "Misti", "Nathan", "Paul", "Sam", "Shane", "Shawna") 'add other names here...
ReDim EmailCount(LBound(arrNames) To UBound(arrNames))
For x = LBound(arrNames) To UBound(arrNames)
On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - IT Support Center"). _
Folders("Onshore - " & arrNames(x)).Folders("completed")
On Error GoTo 0
ArrivalTime = 0
Dim Totalmsg
If Not objFolder Is Nothing Then
For Each MailItem In objFolder.Items
Totalmsg = MailItem.ReceivedTime
Next
End If
Set OutMail = Nothing
Set OutApp = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub

Right now you are overwriting the value of TotalMsg at each iteration in this loop:
If Not objFolder Is Nothing Then
For Each MailItem In objFolder.Items
Totalmsg = MailItem.ReceivedTime
Next
End If
You will want to append to it, instead:
If Not objFolder Is Nothing Then
For Each MailItem In objFolder.Items
Totalmsg = TotalMsg & vbCRLF & MailItem.ReceivedTime
Next
End If
Debug.Print TotalMsg
'Note: this will likely exceed what can fit in the console window, _
' but you can instead write the string to a text file/etc.

Related

Working with ".msg" Items in local folder

I'd like to get some attributes from emails stored in a local folder. I know how to do it for emails in Outlook.folder but I guess the methods are not the same in that case.
I can't find a way to work with the .msg items as if they were emails.
I haven't try anything since I understand the problem comes from object class incompatibility, but I don't know what to use. Also, I couldn't find a guide on ".msg" item, could be useful
Private Sub email_listing()
On Error GoTo ErrHandler
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE AND SET A NameSpace OBJECT.
Dim objNSpace As Object
' THE GetNameSpace() METHOD WILL REPRESENT A SPECIFIED NAMESPACE.
Set objNSpace = objOutlook.GetNamespace("MAPI")
' CREATE A FOLDER OBJECT.
Dim myFolder, fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set myFolder = fs.GetFolder("C:\Users\boris\Desktop\Mail Test\")
Dim Item As Object
Dim iRows, iCols As Integer
iRows = 2
' LOOP THROUGH EACH ITEM IN THE FOLDER.
For Each Item In myFolder.Files
If Item.Type = "Outlook Item" Then
Dim objMail As Outlook.MailItem
Set objMail = Item 'THE BUG
Cells(iRows, 1) = objMail.SenderEmailAddress
Cells(iRows, 2) = objMail.To
Cells(iRows, 3) = objMail.Subject
Cells(iRows, 4) = objMail.ReceivedTime
Cells(iRows, 5) = objMail.Body
End If
iRows = iRows + 1
Next
Set objMail = Nothing
' RELEASE.
Set objOutlook = Nothing
Set objNSpace = Nothing
Set myFolder = Nothing
ErrHandler:
Debug.Print Err.Description
End Sub
I expect to have the attributes for each mail in my spreadsheet.
So far the code stop at line 27
Use Namespace.OpenSharedItem to open standalone MSG files.

Why does loop in email inbox from latest email skip files?

I am trying to download the email attachments in Outlook inbox based on received date. My code downloads attachments, however it skips files.
For example: I was trying to loop the email from the latest email (Received date:01/14/2019). After looping around 10-15 emails, it suddenly jumps to read the email received on 12/07/2018.
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Outlook.MailItem
Set olmail = objOL.CreateItem(olMailItem)
Dim olattachment As Outlook.Attachment
Dim i As Long
Dim filename As String
Dim VAR As Date
'Loop through all item in Inbox
For i = olfolder.Items.Count To 1 Step -1 'Iterates from the end backwards
Set olmail = olfolder.Items(i)
For Each olmail In olfolder
VAR = Format(olmail.ReceivedTime, "MM/DD/YYYY")
filename = olmail.Subject
If VAR = "1/14/2019" Then
For Each olattachment In olmail.Attachments
olattachment.SaveAsFile "C:\Users\Rui_Gaalh\Desktop\Email attachment\" & olattachment.filename
Next
Else
End If
'Mark email as read
olmail.UnRead = False
DoEvents
olmail.Save
Next
Next
MsgBox "DONE"
End Sub
Do not loop through all items in a folder - some folders can have ten of thousands of messages. Use Items.Find/FindNext or Items.Restrict with a query like "[ReceivedTime] >= '2019-01-14' AND [ReceivedTime] < '2019-01-15'".
In case of Items.Find/FindNext, you won't have a problem with skipped emails. In case of Items.Restrict, use a down loop from count down to 1 step -1.
If you are just trying to save Email Attachments that was received on "1/14/2019" then No need for
For Each olmail In olfolder
Next
When you are already using
For i = olfolder.Items.Count To 1 Step -1
next
Here is another one objOL.CreateItem(olMailItem)?? remove it, also Dim olmail as a generic Object - there are objects other than MailItem in your Inbox.
Dim olmail As Outlook.MailItem
Set olmail = objOL.CreateItem(olMailItem)
Set olMail with in the loop then check if the olMail is MailItem
Example
Option Explicit
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.NameSpace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Object
Dim olattachment As Outlook.attachment
Dim i As Long
Dim filename As String
Dim VAR As Date
'Loop through all item in Inbox
For i = olfolder.items.Count To 1 Step -1 'Iterates from the end backwards
DoEvents
Set olmail = olfolder.items(i)
If TypeOf olmail Is Outlook.MailItem Then
VAR = Format(olmail.ReceivedTime, "MM/DD/YYYY")
filename = olmail.Subject
If VAR = "1/14/2019" Then
For Each olattachment In olmail.Attachments
olattachment.SaveAsFile _
"C:\Users\Rui_Gaalh\Desktop\Email attachment\" _
& olattachment.filename
Next
'Mark email as read
olmail.UnRead = False
End If
End If
Next
MsgBox "DONE"
End Sub
You should also look into Items.Restrict method
https://stackoverflow.com/a/48311864/4539709
Items.Restrict method is an alternative to using the Find method or FindNext method to iterate over specific items within a collection. The Find or FindNext methods are faster than filtering if there are a small number of items. The Restrict method is significantly faster if there is a large number of items in the collection, especially if only a few items in a large collection are expected to be found.
Filtering Items Using a String Comparison that DASL filters support includes equivalence, prefix, phrase, and substring matching. Note that when you filter on the Subject property, prefixes such as "RE: " and "FW: " are ignored.
Thanks for all your suggestions. The code works perfectly. Please find the final code below:
Option Explicit
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Object
Dim olattachment As Outlook.Attachment
Dim i As Long
Dim InboxMsg As Object
Dim filename As String
'Set variables
Dim Sunday As Date
Dim Monday As Date
Dim Savefolder As String
Dim VAR As Date
Dim Timestamp As String
Monday = ThisWorkbook.Worksheets(1).Range("B2")
Sunday = ThisWorkbook.Worksheets(1).Range("B3")
Savefolder = ThisWorkbook.Worksheets(1).Range("B4")
'Loop through all item in Inbox
For i = olfolder.Items.Count To 1 Step -1 'Iterates from the end backwards
DoEvents
Set olmail = olfolder.Items(i)
Application.Wait (Now + TimeValue("0:00:01"))
'Check if olmail is emailitem
If TypeOf olmail Is Outlook.MailItem Then
'Set time fram
VAR = olmail.ReceivedTime 'Set Received time
Timestamp = Format(olmail.ReceivedTime, "YYYY-MM-DD-hhmmss") 'Set timestamp format
If VAR <= Sunday And VAR >= Monday Then
For Each olattachment In olmail.Attachments
Application.Wait (Now + TimeValue("0:00:01"))
'Download excel file and non-L10 file only
If (Right(olattachment.filename, 4) = "xlsx" Or Right(olattachment.filename, 3) = "xls")Then
'Set file name
filename = Timestamp & "_" & olattachment.filename
'Download email
olattachment.SaveAsFile Savefolder & "\" & filename
Application.Wait (Now + TimeValue("0:00:02"))
End If
Next
Else
End If
'Mark email as read
olmail.UnRead = False
DoEvents
olmail.Save
Else
End If
Next
MsgBox "DONE"
End Sub

Cannot find default inbox after updating to Office 365

I have code that looks for a specific subject line in an email on Outlook and grabs the attachment from the email.
We merged our emails with a corporate buyout and updated our Microsoft accounts to Office 365. Aside from this, my original VBA code should work since it doesn't look for any specific email folder. All references for Outlook are checked.
I get "nothing" for olMi and it exits the if statement.
Function Report()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim olFldr As MAPIFolder
Dim olItms As Items
Dim olMi As MailItem
Dim olEmail As Outlook.MailItem
Dim olAtt As Attachment
Dim MyPath As String
Dim wB As Workbook
Set olApp = GetObject(, "Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
Set olEmail = olApp.CreateItem(olMailItem)
Set rng = Nothing
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
subj = "Scheduled Report - Instructor List"
Set olMi = olItms.Find("[Subject] = " & Chr(34) & subj & Chr(34))
''___> I get "OlMi = Nothing" here and it used to work
If Not (olMi Is Nothing) Then
For Each olAtt In olMi.Attachments
olAtt.SaveAsFile "C:\Users\Instructor\Desktop\temp\Instructor_Master.xls"
Next olAtt
Else
End If
End Function
The default mailbox can change.
To determine the current default mailbox.
Option Explicit
Private Sub defaultAfterUpgrade()
Dim defInbx As Folder
Dim defMailbox As Folder
Set defInbx = Session.GetDefaultFolder(olFolderInbox)
Set defMailbox = defInbx.Parent
Debug.Print "The default mailbox is: " & defMailbox.name
End Sub
As you found, when this occurs you have to change to the long version of referencing an inbox that includes the mailbox name.

Select Outlook Folder With Excel VBA

I'm trying to bypass having to select the folder I want and just tell Excel to go ahead and count the "Inbox"
Sub Get_Emails()
Dim OLF As Outlook.MAPIFolder
Dim EmailItemCount As Long
Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder
EmailItemCount = OLF.Items.Count
Range("A1") = EmailItemCount
Set OLF = Nothing
Application.StatusBar = False
End Sub
Does anyone know how I can just get the count without having to select the folder? Excel VBA should just automatically go into the "Inbox" and give me my count.
Note: You have to go to Tools > References > and select "Microsoft Outlook 14.0 Object Library" in order for this macro to work.
Here is something that works:
Option Explicit
Sub LoopFoldersInInbox()
Dim ns As Outlook.Namespace
Dim myfolder As Outlook.Folder
Dim mysubfolder As Outlook.Folder
Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set myfolder = ns.GetDefaultFolder(olFolderInbox)
For Each mysubfolder In myfolder.Folders
Debug.Print mysubfolder.name
Debug.Print mysubfolder.Items.Count
Next mysubfolder
End Sub
With some credits here. It is with early binding. Thus, if you press the dot in ns or mysubfolder you will see the properties and the actions they have:
Here is the late binding, thus you do not need to refer to the Outlook Library explicitly and the code would work on more users:
Option Explicit
Sub LoopFoldersInInbox()
Dim ns As Object
Dim objFolder As Object
Dim objSubfolder As Object
Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set objFolder = ns.GetDefaultFolder(6) ' 6 is equal to olFolderInbox
For Each objSubfolder In objFolder.Folders
Debug.Print objSubfolder.name
Debug.Print objSubfolder.Items.Count
Next objSubfolder
End Sub
In this late binding, I have used 6 in stead of olFolderInbox.
Edit:
If you want the results in the cells, use this code:
Option Explicit
Sub LoopFoldersInInbox()
Dim ns As Object
Dim objFolder As Object
Dim objSubfolder As Object
Dim lngCounter As Long
Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set objFolder = ns.GetDefaultFolder(6) ' 6 is equal to olFolderInbox
For Each objSubfolder In objFolder.Folders
With ActiveSheet
lngCounter = lngCounter + 1
.Cells(lngCounter, 1) = objSubfolder.Name
.Cells(lngCounter, 2) = objSubfolder.Items.Count
End With
Debug.Print objSubfolder.Name
Debug.Print objSubfolder.Items.Count
Next objSubfolder
End Sub
The below is more of what I am looking for but Vityana's code works very well too. It all depends on what you need. I would like to specify a folder within the "Inbox" but am currently unable to. This only gets the count for the "Inbox" but there are folders nested under the "Inbox" folder that I am unable to specify. Anyone know how to do that?
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Joe.L.Smo#company.com").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
[B2].Value = EmailCount
End Sub
You can just "continue the specification".
You had:
Set objFolder = objnSpace.Folders("Joe.L.Smo#company.com").Folders("Inbox")
To get -for example- the content of the subfolder Temp under the Inbox, specify:
Set objFolder = objnSpace.Folders("Joe.L.Smo#company.com").Folders("Inbox").Folders("Temp")
Hope this helps

Searching Outlook Folder

I want to search a specific Outlook folder using an activecell value.
I tried Excel VBA for searching in mails of Outlook and VBA Search in Outlook.
The closest I was able to get:
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim OutlookSearch as string
Outlooksearch = Cstr(Activecell.cells(1,4).Value)
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "sketch") > 0 Then
Debug.Print "Found"
Found = True
End If
End If
Next myitem
'If the subject isn't found:
If Not Found Then
MsgBox "Cannot find"
End If
myOlApp.Quit
Set myOlApp = Nothing
I want to use the string in Activecell.cells(1, 4) as the subject for a search in a specific Outlook folder in the inbox.
I get is the MsgBox even if I've sent an email containing values that match with activecell.
You can specify the folder to search in, within the inbox, by using the .Folders property.
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("myFolder")
I've had a play around and come up with the code below. No need to set references to Outlook.
Sub Test1()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim cFolder As Object
Dim oItem As Object
Dim oMyItem As Object
Dim sOutlookSearch As String
Dim aFolders() As String
Dim i As Long
'sOutlookSearch needs to be something like:
'"Mailbox - Darren Bartrup-Cook\Inbox"
sOutlookSearch = ThisWorkbook.Worksheets("Sheet1").Cells(1, 4)
sOutlookSearch = Replace(sOutlookSearch, "/", "\")
aFolders() = Split(sOutlookSearch, "\")
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.Folders.Item(aFolders(0))
If Not mFolderSelected Is Nothing Then
For i = 1 To UBound(aFolders)
Set cFolder = mFolderSelected.Folders
Set mFolderSelected = Nothing
Set mFolderSelected = cFolder.Item(aFolders(i))
If mFolderSelected Is Nothing Then
Exit For
End If
Next i
End If
'Set mFolderSelected = nNameSpace.PickFolder 'Alternative to above code block - just pick the folder.
For Each oItem In mFolderSelected.items
If oItem.class = 43 Then '43 = olmail
If InStr(1, oItem.Subject, "sketch") > 0 Then
Debug.Print "Found: " & oItem.sendername
Exit For
End If
End If
Next oItem
End Sub
The code block for finding the correct folder was taken from here:
http://www.outlookcode.com/d/code/getfolder.htm