The below code will delete email from the Deleted Items folder.
How do I delete emails from a subfolder of the Deleted Items folder called "Extra"?
Sub DeletedItems()
Dim lCount As Long
Dim lCtr As Long
Dim lDelete As Long
Dim oFolder As Folder
Dim oItems As Items
Set oFolder = Outlook.Session.Folders("profile.com").Folders("Deleted Items")
Set oItems = oFolder.Items
lCount = oItems.Count
On Error Resume Next
lDelete = InputBox("Enter number to delete:", , lCount)
On Error GoTo 0
If lDelete = 0 Then
Exit Sub
End If
For lCtr = lDelete To 1 Step -1
oItems(lCtr).Delete
Next
End Sub
Try the next code, plese:
Sub DeleteSubfolderItems()
Dim lCount As Long, lCtr As Long, lDelete As String, oFolder As MAPIFolder
Dim objOutlook As New Outlook.Application, olSubFolder As MAPIFolder, oItems As Items
Set oFolder = objOutlook.Session.GetDefaultFolder(olFolderDeletedItems) 'Trash folder...
Set olSubFolder = oFolder.Folders("Test Trash") 'use here your subfolder
Set oItems = olSubFolder.Items
lCount = oItems.count
lDelete = InputBox("Enter number to delete:", , lCount)
If lDelete = "" Then
Exit Sub
End If
For lCtr = CLng(lDelete) To 1 Step -1
'Debug.Print oItems.item(lCtr).subject
oItems(lCtr).Delete
Next
End Sub
Related
Goodafternoon,
I am populating an list box with all the emails from Inbox + Subfolders, via Table object. This is working fine.
Then, with Doubleclick events from ListBox1, I am trying to open the email that is been selected. If the loop is going only through Inbox folder, it is going correct. But when I'm trying to loop through SubFolders from Inbox, it is not going. So I am trying to collect(sum) all the emails from Inbox + subfolder in one:
Set InboxItems = SubFolder.Items
But offcorse it is not working. What can be done?
my code:
Option Explicit
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim objNS As Outlook.namespace: Set objNS = GetNamespace("MAPI")
Dim oFolder As Outlook.MAPIFolder: Set oFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim i As Long
Dim j As Long
Dim InboxItems As Outlook.Items
Dim thisEmail As Outlook.MailItem
Dim SubFolder As Outlook.MAPIFolder
Dim myArray() As String
Dim Folders As New Collection
Dim entryID As New Collection
Dim StoreID As New Collection
Call GetFolder(Folders, entryID, StoreID, oFolder)
myArray = ConvertToArray(indexEmailInbox)
For j = 1 To Folders.Count
Set SubFolder = Application.Session.GetFolderFromID(entryID(j), StoreID(j))
Set InboxItems = SubFolder.Items
Next
For i = LBound(myArray) To UBound(myArray)
If Me.ListBox1.Selected(i) = True Then
If TypeName(InboxItems.Item(onlyDigits(myArray(i)))) = "MailItem" Then ' it's an email
'MsgBox onlyDigits(myArray(UBound(myArray) - i - 1))
Set thisEmail = InboxItems.Item(onlyDigits(myArray(UBound(myArray) - i - 1)))
Unload Me
thisEmail.Display
Exit Sub
End If
End If
Next i
End Sub
Function ConvertToArray(ByVal value As String)
value = StrConv(value, vbUnicode)
ConvertToArray = Split(Left(value, Len(value) - 1), "ยง")
End Function
Sub GetFolder(folders As Collection, entryID As Collection, StoreID As Collection, fld As MAPIFolder)
Dim SubFolder As MAPIFolder
folders.Add fld.FolderPath
entryID.Add fld.entryID
StoreID.Add fld.StoreID
For Each SubFolder In fld.folders
GetFolder folders, entryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
You may .Add items to a collection one at a time.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub collection_Emails_Folder_And_Subfolders()
Dim objFolder As folder
Dim myItemsCol As New Collection
Dim i As Long
Dim myItems As Items
Set objFolder = Session.PickFolder
If objFolder Is Nothing Then
Exit Sub
End If
'Set objFolder = Session.GetDefaultFolder(olFolderInbox)
processFolder objFolder, myItemsCol
' Methods available are limited to:
' Add, Count, Item and Remove
Debug.Print vbCr & "Final total - myItemsCol.Count: " & myItemsCol.Count
' You may access item properties
For i = 1 To myItemsCol.Count
Debug.Print " " & i & ": " & myItemsCol(i).ReceivedTime, myItemsCol(i).subject
Next i
End Sub
Private Sub processFolder(ByVal objFolder As folder, ByVal myItemsCol As Collection)
' https://stackoverflow.com/questions/2272361/can-i-iterate-through-all-outlook-emails-in-a-folder-including-sub-folders
Dim EmailCount As Long
Dim myItem As Object
Dim myItems As Items
Dim i As Long
Dim oFolder As folder
Debug.Print vbCr & "objFolder: " & objFolder
EmailCount = objFolder.Items.Count
Debug.Print " EmailCount...: " & EmailCount
If EmailCount > 0 Then
Set myItems = objFolder.Items
myItems.Sort "[ReceivedTime]", False ' oldest to newest
For i = 1 To myItems.Count
'Debug.Print " " & i & ": " & myItems(i).ReceivedTime, myItems(i).subject
myItemsCol.Add myItems(i)
Next
End If
Debug.Print " Running total: " & myItemsCol.Count
If (objFolder.Folders.Count > 0) Then
For Each oFolder In objFolder.Folders
processFolder oFolder, myItemsCol
Next
End If
End Sub
You should be able to replace InboxItems with myItemsCol.
If TypeName(myItemsCol.Item((onlyDigits(myArray(i)))) = "MailItem" Then ' it's an email
Set thisEmail = myItemsCol.Item(onlyDigits(myArray(UBound(myArray) - i - 1)))
It seems you just need to iterate over all subfolders in Outlook to get the number of items per folder.
Sub Test()
Set objOutlook = CreateObject( "Outlook.Application" )
Set objNamespace = objOutlook.GetNamespace( "MAPI" )
Set folders = objNamespace.DefaultStore.GetRootFolder().Folders
EnumFolders folders
End Sub
Dim counter as Long = 0
' recursively invoked function
Sub EnumFolders(folders)
For Each folder In folders
Debug.Print folder.FolderPath
Debug.Print folder.Count
counter = counter + folder.Items.Count
EnumFolders folder.Folders
Next
End Sub
I would like to export the count by category for multiple folders from Outlook to Excel.
I have tried to use a For...Loop, but it loops the current folders instead of looping the subfolders.
Sub CategoriesEmails()
Dim oFolder As MAPIFolder
Dim oDict As Object
Dim sStartDate As String
Dim sEndDate As String
Dim oItems As Outlook.Items
Dim sStr As String
Dim sMsg As String
Dim strFldr As String
Dim OutMail As Object
Dim xlApp As Object
On Error Resume Next
Set oFolder = Application.ActiveExplorer.CurrentFolder
Set oDict = CreateObject("Scripting.Dictionary")
sStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
sEndDate = InputBox("Type the end date (format MM/DD/YYYY)")
Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
oItems.SetColumns ("Categories")
For Each aItem In oItems
sStr = aItem.Categories
If Not oDict.Exists(sStr) Then
oDict(sStr) = 0
End If
oDict(sStr) = CLng(oDict(sStr)) + 1
Next aItem
sMsg = ""
For Each aKey In oDict.Keys
sMsg = sMsg & aKey & ": " & oDict(aKey) & vbCrLf
Next
MsgBox sMsg
strFldr = ""
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
xlApp.Workbooks.Open strFldr & "CountByCategories.xlsx"
xlApp.Sheets("Sheet1").Select
For Each aKey In oDict.Keys
xlApp.Range("A1") = "Folder Name"
xlApp.Range("A1").Font.Bold = True
xlApp.Range("B1") = "Category"
xlApp.Range("B1").Font.Bold = True
xlApp.Range("C1") = "Count"
xlApp.Range("C1").Font.Bold = True
xlApp.Range("D1") = "Start Date"
xlApp.Range("D1").Font.Bold = True
xlApp.Range("E1") = "End Date"
xlApp.Range("E1").Font.Bold = True
xlApp.Range("A2").Offset(i, 0).Value = oFolder
xlApp.Range("B2").Offset(i, 0).Value = aKey
xlApp.Range("C2").Offset(i, 0).Value = oDict(aKey) & vbCrLf
xlApp.Range("D2").Offset(i, 0).Value = sStartDate
xlApp.Range("E2").Offset(i, 0).Value = sEndDate
i = i + 1
Next
xlApp.Save
Set oFolder = Nothing
End Sub
I could successfully export the count by category for a particular folder but fail to do so for multiple folders.
A sample code enumerates all folders on all stores for a session:
Sub EnumerateFoldersInStores()
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oRoot As Outlook.Folder
On Error Resume Next
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oRoot = oStore.GetRootFolder
Debug.Print (oRoot.FolderPath)
EnumerateFolders oRoot
Next
End Sub
Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder)
Dim folders As Outlook.folders
Dim Folder As Outlook.Folder
Dim foldercount As Integer
On Error Resume Next
Set folders = oFolder.folders
foldercount = folders.Count
'Check if there are any folders below oFolder
If foldercount Then
For Each Folder In folders
' here you can call your function to gather all categories from a folder
' Sub CategoriesEmails(Folder)
Debug.Print (Folder.FolderPath)
EnumerateFolders Folder
Next
End If
End Sub
The code sample begins by getting all the stores for the current session using the NameSpace.Stores property of the current Application.Session.
For each store of this session, it uses Store.GetRootFolder to obtain the folder at the root of the store.
For the root folder of each store, it iteratively calls the EnumerateFolders procedure until it has visited and displayed the name of each folder in that tree.
I have a problem looping through every sub-folder of an Outlook email using following code:
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
'Set objFolder = ActiveExplorer.CurrentFolder
Set objFolder = Session.GetFolderFromID (Application.ActiveExplorer.CurrentFolder.EntryID)
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
' MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim oStartDate As String
Dim oEndDate As String
Set dict = CreateObject("Scripting.Dictionary")
oStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
oEndDate = InputBox("Type the end date (format MM/DD/YYYY)")
Set myItems = objFolder.Items.Restrict("[Received] >= '" & oStartDate & "' And [Received] <= '" & oEndDate & "'")
myItems.SetColumns ("Categories")
' date for mssg:
For Each myItem In myItems
dateStr = myItem.Categories
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output for days
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & vbCrLf
Next
MsgBox msg
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
The code runs on the inbox itself, but it doesn't dig into sub-folders.
I have been trying to loop it correctly but I keep failing.
Thanks for help!
The code in ProcessFolder will call itself for each subfolder within the parent folder.
Option Explicit
Private MessageText As String
Public Sub ListAllFolders()
'Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
'''''''''''''''''''''''''''''''''''''''''
'No need to reference the Outlook application as the code
'is running from within the application itself.
''''''''''''''''''''''''''''''''''''''''
'Set oOutlook = GetObject(, "Outlook.Application")
'Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set nNameSpace = GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
ProcessFolder mFolderSelected
MsgBox MessageText
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
'Get the folder name and count of items.
MessageText = MessageText & oParent.Name & ": " & oParent.Items.Count & vbCr
'If there are subfolders then process them as well.
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
End Sub
Edit:
This is the code I use to count the different categories of emails in the selected folder & subfolders.
It splits the count by date and category:
Public Sub CreateReport()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim oItem As Object
Dim rLastCell As Range
Dim x As Long
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
''''''''''''''''''''''''''''''''
'Clear Sheet of existing data. '
''''''''''''''''''''''''''''''''
shtAnalysis.Cells.Delete Shift:=xlUp
ProcessFolder mFolderSelected
''''''''''''''''''''''''''
'Tidy up and add totals. '
''''''''''''''''''''''''''
Set rLastCell = LastCell(shtAnalysis)
ThisWorkbook.Activate
MsgBox "Complete", vbOKOnly
End Sub
Private Sub ProcessFolder(oParent As Object)
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMail As Object
Dim sName As String
Dim PropertyAccessor As Object
Dim v As Variant
On Error Resume Next
For Each oMail In oParent.Items
PlaceDetails oMail
Next oMail
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
ProcessFolder oFolder
Next oFolder
End If
On Error GoTo 0
End Sub
Sub PlaceDetails(oMailItem As Object)
Dim rFoundCell As Range
Dim lColumn As Long
Dim lRow As Long
'''''''''''''''''''''''''''''''''''''''''''''
'Only process emails containing a category. '
'''''''''''''''''''''''''''''''''''''''''''''
If oMailItem.categories <> "" Then
With shtAnalysis
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Does the category already exist on the spreadsheet? '
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Rows("1:1").Cells.Find(What:=oMailItem.categories, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lColumn = rFoundCell.Column
Else
lColumn = LastCell(shtAnalysis).Column + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Next find the row by looking for sent on date in column A. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rFoundCell = .Columns("A:A").Cells.Find(What:=Int(oMailItem.senton), After:=.Cells(2, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not rFoundCell Is Nothing Then
lRow = rFoundCell.Row
Else
lRow = LastCell(shtAnalysis).Row + 1
End If
Set rFoundCell = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''
'Place category, date and count on the sheet. '
'''''''''''''''''''''''''''''''''''''''''''''''
.Cells(lRow, 1).Value = Int(oMailItem.senton)
.Cells(1, lColumn).Value = oMailItem.categories
If .Cells(lRow, lColumn) = "" Then
.Cells(lRow, lColumn).NumberFormat = "General"
.Cells(lRow, lColumn) = 1
Else
.Cells(lRow, lColumn) = .Cells(lRow, lColumn) + 1
End If
End With
End If
End Sub
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
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")
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.