Iterate through Outlook subfolders and inbox - vba

I have this code below which loops through the inbox, searching for a specific e-mail address entered on the worksheet's column E. it will return the last e-mail sent date to column b.
Sub ()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim icounter As Long
Dim lrow As Long
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("-")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.Count, "E").End(xlUp).Row
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
For icounter = 2 To lastrow
If InStr(olMail.SenderEmailAddress, ws.Cells(icounter, 5).Value) > 0 Then 'qualify the cell
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("B" & lrow + 1).Value = olMail.ReceivedTime
.Range("A" & lrow + 1).Value = olMail.SenderEmailAddress
End With
End If
Next icounter
End If
Next i
Set olFolder = Nothing
End Sub
I'm not sure how to loop through the subfolders. I've checked SO and found this code below from Can I iterate through all Outlook emails in a folder including sub-folders?
Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
For Each oMail In oParent.Items
'Get your data here ...
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
But i've never used private subs so I don't know how to combine them..
Also found this which is the combined version using the private sub i found above, but I had no luck in translating it to my code. Outlook VBA Importing Emails from Subfolders into Excel

The private sub sits in a module and is only available to that module, you can call the sub by writing:
Call processFolder(The Outlook.MAPIFolder)
This sub requires an input variable oParent which is in the form of Outlook.MAPIFolder.

Related

Outlook scan through the Inbox for a specific string in the subject

I'm working on a project were I need a macro in outlook that will scan through the inbox for an e-mail with a "reference number" contained with-in the subject field. If no e-mail was detected, the system can then move on to the next reference from an excel spreadsheet.
If an e-mail was detected, it gets extracted as an "MSG" file and the actual e-mail moved into a subfolder. So far I have a code for extracting the e-mails as "MSG" files but I cant get it to identify the specific string (reference No) in the subject field. I got the below EXCEL Macro code so far from this site.
Sub Work_with_Outlook()
Set outlookApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.NameSpace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim sir() As String
Set outlookApp = New Outlook.Application
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""Macro""")
If Not (olMail Is Nothing) Then
olMail.Display
End If
End Sub
Try below code:
Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myFolder, destFolder As Outlook.MAPIFolder
Dim i, lr As Long
'last used row in excel
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set myOlapp = GetObject(, "Outlook.application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set destFolder = myFolder.Folders("provide subFolderName here")
Set mytask = myFolder.Items
'Download and move attachment if found
For i = 1 To lr
'The below line of code will not work if you are using wild card or partial string
Set ref = mytask.Find("[Subject] =" & Range("a" & i).Value)
If Not (ref Is Nothing) Then
ref.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
ref.Move destFolder
End If
Set ref = Nothing
'The workaround code goes as below
For Each myItem In mytask
If myItem.Class = olMail Then
If InStr(1, myItem.Subject, Range("a" & i).Value) > 0 Then
myItem.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
myItem.Move destFolder
End If
End If
Next myItem
Next i
Set myOlapp = Nothing
Set myNameSpace = Nothing
Set myFolder = Nothing
Set destFolder = Nothing
Set mytask = Nothing
End Sub
Note: Assuming reference number is in "A" Column

Copy email subject in outlook to excel using vba with two email address?

I have two email address. The first is address1#domain.com.vn and the second is address2#domain.com.vn.
I want to copy email subject in microsoft outlook with second address address2#domain.com.vn to excel using vba. I use bellow code but it do not work.
Sub GetFromInbox()
Dim olapp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim Pst_Folder_Name
Dim MailboxName
'Dim date1 As Date
Dim i As Integer
Sheets("sheet1").Visible = True
Sheets("sheet1").Select
Cells.Select
Selection.ClearContents
Cells(1, 1).Value = "Date"
Set olapp = New Outlook.Application
Set olNs = olapp.GetNamespace("MAPI")
Set Fldr = olNs.ActiveExplorer.CurrentFolder.Items
MailboxName = "address2#domain.com.vn"
Pst_Folder_Name = "Inbox"
Set Fldr = Outlook.Session.Folders(MailboxName).Folders(Pst_Folder_Name)
i = 2
For Each olMail In Fldr.Items
'For Each olMail In olapp.CurrentFolder.Items
ActiveSheet.Cells(i, 1).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.Subject
ActiveSheet.Cells(i, 4).Value = olMail.SenderName
i = i + 1
Next olMail
End Sub
try this
Sub GetFromInbox()
Dim olapp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim Pst_Folder_Name As String, MailboxName As String
Dim i As Long
MailboxName = "address2#domain.com.vn"
Pst_Folder_Name = "Inbox"
Set olapp = New Outlook.Application
Set olNs = olapp.GetNamespace("MAPI")
Set Fldr = olNs.Folders(MailboxName).Folders(Pst_Folder_Name)
With Sheets("sheet1")
.Cells.ClearContents
.Cells(1, 1).Value = "Date"
i = 2
For Each olMail In Fldr.Items
'For Each olMail In olapp.CurrentFolder.Items
.Cells(i, 1).Value = olMail.ReceivedTime
.Cells(i, 3).Value = olMail.Subject
.Cells(i, 4).Value = olMail.SenderName
i = i + 1
Next olMail
End With
olapp.Quit
Set olapp = Nothing
End Sub
If your using ActiveExplorer.CurrentFolder then you don't need to set your email Inbox, code should run on currently displayed folder in explorer.
Example
Option Explicit
Public Sub Example()
Dim Folder As MAPIFolder
Dim CurrentExplorer As Explorer
Dim Item As Object
Dim App As Outlook.Application
Dim Items As Outlook.Items
Dim LastRow As Long, i As Long
Dim xlStarted As Boolean
Dim Book As Workbook
Dim Sht As Worksheet
Set App = Outlook.Application
Set Folder = App.ActiveExplorer.CurrentFolder
Set Items = Folder.Items
Set Book = ActiveWorkbook
Set Sht = Book.Worksheets("Sheet1")
LastRow = Sht.Range("A" & Sht.Rows.Count).End(xlUp).Row
i = LastRow + 1
For Each Item In Items
If Item.Class = olMail Then
Sht.Cells(i, 1) = Item.ReceivedTime
Sht.Cells(i, 2) = Item.SenderName
Sht.Cells(i, 3) = Item.Subject
i = i + 1
Book.Save
End If
Next
Set Item = Nothing
Set Items = Nothing
Set Folder = Nothing
Set App = Nothing
End Sub

Emails to a distribution group aren't MailItems?

I'm trying to write a VBA script for Outlook 2007 that moves a user's mail to an "Expired" folder if it's older than 89 days. I have code to do this, but it doesn't seem to work for aged emails that were to a distribution group that includes the end user. It works for emails just sent to the end user.
I combined code I found online for a) moving emails when they are a certain number of days old (http://www.slipstick.com/developer/macro-move-aged-mail/), and b) recursing through a folder to apply the code to subfolders as well (Can I iterate through all Outlook emails in a folder including sub-folders?). This code recurses through the Inbox folder and subfolders to move all aged mail.
It more or less works, but for some reason emails to a distribution list that includes the end user are not being picked up. The only remarkable check I have is that
If TypeName(oItem) = "MailItem"
Are distribution list emails not considered MailItems? If not, how do I make sure to catch those too?
Here is the complete code:
Public Sub MoveAgedMail(Item As Outlook.MailItem)
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim Folder As Outlook.MAPIFolder
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
' Call processFolder
processFolder objSourceFolder
End Sub
Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim oItem As Object
Dim intCount As Integer
Dim intDateDiff As Long
Dim objDestFolder As Outlook.MAPIFolder
' "Expired" folder at same level as Inbox for sending aged mail
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")
For Each oItem In oParent.Items
If TypeName(oItem) = "MailItem" Then
Set oMail = oItem
' Check if email is older than 89 days
intDateDiff = DateDiff("d", oMail.SentOn, Now)
If intDateDiff > 89 Then
' Move to "Expired" folder
oMail.Move objDestFolder
End If
End If
Next oItem
' Recurse through subfolders
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
Set objDestFolder = Nothing
End Sub
Firstly, do not use for each if you are modifying a collection - that will cause your code to skip half the items.
Secondly, do not just loop through all items in a folder, this is extremely inefficient. Use Items.Restrict or Items.Find/FindNext.
Try something like the following (VB script):
d = Now - 89
strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
set oItems = oParent.Items.Restrict(strFilter)
for i = oItems.Count to 1 step -1
set oItem = oItems.Item(i)
Debug.Print oItem.Subject & " " & oItem.SentOn
next
Try not to process Expired Folder
' Recurse through subfolders
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
Debug.Print oFolder
' No need to process Expired folder
If oFolder.Name <> "Expired" Then
processFolder oFolder
End If
Next
End If
also try using down loop when moving mail items, see Dmitry Streblechenko example
Edit
Items.Restrict Method (Outlook)
Complete Code- Tested on Outlook 2010
Sub MoveAgedMail(Item As Outlook.MailItem)
Dim olNameSpace As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olNameSpace = Application.GetNamespace("MAPI")
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
' // Call ProcessFolder
ProcessFolder olInbox
End Sub
Function ProcessFolder(ByVal Parent As Outlook.MAPIFolder)
Dim Folder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
Dim iCount As Integer
Dim iDateDiff As Long
Dim vMail As Variant
Dim olItems As Object
Dim sFilter As String
iDateDiff = Now - 89
sFilter = "[SentOn] < '" & Month(iDateDiff) & "/" & Day(iDateDiff) & "/" & Year(iDateDiff) & "'"
' // Loop through the items in the folder backwards
Set olItems = Parent.Items.Restrict(sFilter)
For iCount = olItems.Count To 1 Step -1
Set vMail = olItems.Item(iCount)
Debug.Print vMail.Subject ' helps me to see where code is currently at
' // Filter objects for emails
If vMail.Class = olMail Then
Debug.Print vMail.SentOn
' // Retrieve a folder for the destination folder
Set DestFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Expired")
' // Move the emails to the destination folder
vMail.Move DestFolder
' // Count number items moved
iCount = iCount + 1
End If
Next
' // Recurse through subfolders
If (Parent.Folders.Count > 0) Then
For Each Folder In Parent.Folders
If Folder.Name <> "Expired" Then ' skip Expired folder
Debug.Print Folder.Name
ProcessFolder Folder
End If
Next
End If
Debug.Print "Moved " & iCount & " Items"
End Function
This is my code now. Originally, I moved my old mail to an "Expired" folder and had autoarchive delete the messages, but I was having issues with autoarchive on some machines. I rewrote the script to delete old email. It uses Dmitry Streblechenko's suggestions, and it seems to work.
Public Sub DeleteAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objSourceFolderSent As Outlook.MAPIFolder
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set objSourceFolderSent = objNamespace.GetDefaultFolder(olFolderSentMail)
processFolder objSourceFolder
processFolder objSourceFolderSent
emptyDeleted
End Sub
Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oItems As Outlook.Items
Dim oItem As Object
Dim intDateDiff As Long
Dim d As Long
Dim strFilter As String
d = Now - 89
strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
Set oItems = oParent.Items.Restrict(strFilter)
For i = oItems.Count To 1 Step -1
Set oItem = oItems.Item(i)
If TypeName(oItem) = "MailItem" Then
oItem.UserProperties.Add "Deleted", olText
oItem.Save
oItem.Delete
End If
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
Public Sub emptyDeleted()
Dim objOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim objDeletedFolder As Outlook.MAPIFolder
Dim objProperty As Outlook.UserProperty
Set objOutlook = Application
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set objDeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.Items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
If you want to just move emails and not delete them, like in my original code, you could get rid of the emptyDeleted() function, change
oItem.UserProperties.Add "Deleted", olText
oItem.Save
oItem.Delete
back to
oItem.Move objDestFolder
and add these two lines back to the processFolder() function:
Dim objDestFolder As Outlook.MAPIFolder
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")

VBA Code not populating worksheet

The code below is sourced from another SO post: Excel VBA Code to retrieve e-mails from outlook.
THe purpose is to find information from Outlook e-mails and put them into Excel.
Sub test2()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder
Dim i As Long
Dim x As Date
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Sheet1")
wb.Activate
ws.Select
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For i = olFolder.Items.Count To 1 Step -1
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
For iCounter = 2 To lrow
If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & lrow).Offset(1, 0).Value = olMail.Subject
.Range("A" & lrow).Offset(1, 1).Value = olMail.ReceivedTime
.Range("A" & lrow).Offset(1, 2).Value = olMail.SenderEmailAddress
End With
End If
Next iCounter
End If
Next i
Set olFolder = Nothing
Next eFolder
End Sub
WHen i debug and hover over the last few lines, it seems the code is extracting information from Outlook properly. However, the extracted data(subject of e-mail, etc) aren't populated in my worksheet. From what I can gather I've set the worksheet variable correctly, don't really know what's going on.
Thanks for all the help
Update:
Worksheet is populating now. I am trying to get the code to go through a column of e-mail addresses, and extract "time received" from the emails if the addresses match with those in my folders.
Made some changes. See if this works.
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim eFolder As Outlook.folder
Dim i As Long
Dim x As Date
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Set wb = ActiveWorkbook
Set ws = wb.WorkSheets("Sheet1")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
x = Date
'i think you want column E here, not L?
lastRow = ThisWorkbook.WorkSheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Row
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.name)
For i = olFolder.Items.Count To 1 Step -1
For iCounter = 2 To lastRow
If TypeOf olFolder.Items(i) Is MailItem Then
Set olMail = olFolder.Items(i)
If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & lrow + 1).Value = olMail.SUBJECT
.Range("B" & lrow + 1).Value = olMail.ReceivedTime
.Range("C" & lrow + 1).Value = olMail.SenderEmailAddress
End With
End If
Next iCounter
End If
Next i
Set olFolder = Nothing
Are the emails you're looking for in your inbox or a subfolder? The code is ONLY looking in each FOLDER in the inbox, it's not looking in the actual inbox.
Try these changes:
Dim i As Long, j As Long 'Add "j as long"
'For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
For j = 0 To olNs.GetDefaultFolder(olFolderInbox).Folders.Count ' loop through the folders, starting at 0 (which we'll call the inbox)
If j = 0 Then
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
Else
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(j)
End If
...rest of loop
Next ' Remove 'efolder' from here

Run time error 13 on for-each loop after a few items

I am trying to list all email in Excel within all sub folders from Outlook:
I have searched and researched this for weeks without any luck.
'Requires reference to Outlook library
Option Explicit
Public Sub ListOutlookFolders()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim rngOutput As Range
Dim lngCol As Long
Dim olItem As Outlook.MailItem
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Set rngOutput = ActiveSheet.Range("A1")
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
For Each olFolder In olNamespace.Folders
rngOutput = olFolder.Name
rngOutput.Offset(0, 1) = olFolder.Description
Set rngOutput = rngOutput.Offset(1)
For Each olItem In olFolder.Items
Set rngOutput = rngOutput.Offset(1)
With rngOutput
.Offset(0, 1) = olItem.SenderEmailAddress ' Sender
End With
Next
Set rngOutput = ListFolders(olFolder, 1, rngOutput)
Next
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub
Function ListFolders(MyFolder As Outlook.MAPIFolder, Level As Integer, theOutput As Range) As Range
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Outlook.MailItem
Dim lngCol As Long
For Each olFolder In MyFolder.Folders
theOutput.Offset(0, lngCol) = olFolder.Name
Set theOutput = theOutput.Offset(1)
If (olFolder.DefaultItemType = olMailItem) And (Not olFolder.Name = "Slettet post") Then
For Each olItem In olFolder.Items
If olItem.Class = olMail Then
With theOutput
.Offset(0, 1) = olItem.SenderEmailAddress ' Sender
End With
Set theOutput = theOutput.Offset(1)
End If
Next olItem <--- ERROR 13 here
End If
If olFolder.Folders.Count > 0 Then
Set theOutput = ListFolders(olFolder, Level + 1, theOutput)
End If
Next olFolder
Set ListFolders = theOutput.Offset(1)
End Function
The code runs fine for 10-20 items and then gives me an run time error 13 in the line stated above and when I hit debug it tells me that olItem is = Nothing !? - When I hit single step the code runs again fine for a while again.
I have tried to insert a "ON ERROR" but then my list doesn't contain all emails.
I'm baring my code to you :)
Change
Dim olItem As Outlook.MailItem
to
Dim olItem As Object
Not all the folder items will be mailitems, so avoid dimensioning your olItem variable in this manner. This change worked fine on my machine, while originally I had the same error you did