I have a macro which is supposed to delete emails over 'x' amount of days old when I quit Outlook 2007 but it only seems to delete a few of them and when I open it and quit again it deleted the rest. Here is the code:
Private Sub Application_Quit()
Dim myOlApp, myNameSpace As Object
Dim MyItem As Object
Dim DeletedFolder As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
'Set DeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
Set DeletedFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Auto")
For Each MyItem In DeletedFolder.Items
If DateDiff("d", MyItem.ReceivedTime, Now) > 7 Then
MyItem.Delete
End If
Next
End Sub
In this example I chose greater than 7 days old in the Auto folder under my Inbox folder.
Any ideas why it does not delete them all the first time?
Thanks
Generally when deleting you need a different sort of iteration:
Dim m as Long
For m = DeletedFolder.Items.Count to 1 Step -1
Set myItem = DeletedFolder.Items(m)
If DateDiff("d", MyItem.ReceivedTime, Now) > 7 Then
MyItem.Delete
End If
Next
This is because, as you delete an element from the collection, the collection is re-indexed. So you need to step backwards through the collection, otherwise you will "skip" some items.
Related
We have a shared mailbox, and the alerts folder gets filled with alerts. Thousands of them - most from start of day and end of day. New alerts in the middle of the day might actually be something that we need look at.
Noone ever bulk marks the folder as read in the morning, because it takes too long - you can't highlight the who mailbox and click "mark as unread". The onely way to mark the emails is by highlighting a few hundred at a time - which takes along time manually.
I made thsi script because it will automagically mark the emails in the "alerts' folder. However, it seems to go after the whole folder at the same time. The script ist eh equivalent of highlightimg the whole folder, and marking a bulk delete. It takes to long and locks up the shared email box. I would like something that would start at the bottom of the folder, cycle through each email, and if unread, mark the email unread. pause for a second, then the next one.
Is that possible?
Sub Test2()
Dim objInbox As Outlook.MAPIFolder
Dim objOutlook As Object, objnSpace As Object, objMessage As Object
Dim objSubfolder As Outlook.MAPIFolder
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objInbox = objnSpace.GetDefaultFolder(olFolderInbox)
Set objSubfolder = objInbox.Folders.Item("_ALERTS")
For Each objMessage In objSubfolder.Items
objMessage.UnRead = False
Next
Set objOutlook = Nothing
Set objnSpace = Nothing
Set objInbox = Nothing
Set objSubfolder = Nothing
End Sub
You can create a code in Outlook which get triggers when new Email entered in a target folder.
Public WithEvents objMails As Outlook.Items
Private Sub Application_Startup()
Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Folders("_ALERTS").Items
End Sub
Private Sub objMails_ItemAdd(ByVal Item As Object)
'Do more stuff
End Sub
which will avoid looping through all the emails at a time
You could use Restrict to limit the items to be processed.
Option Explicit
Sub Test2()
Dim objInbox As Folder
Dim objnSpace As namespace
Dim objSubfolder As Folder
dim unreadItems As items
dim unreaditemsCount as long
Set objnSpace = GetNamespace("MAPI")
Set objInbox = objnSpace.GetDefaultFolder(olFolderInbox)
Set objSubfolder = objInbox.Folders.Item("_ALERTS")
set unreadItems = objSubfolder.Items.Restrict("[UnRead] = True")
unreaditemsCount = unreadItems.Count
If unreaditemsCount > 0 Then
' Reverse loop when changing the number of items in the collection
For i = unreaditemsCount to 1
unreadItems(i).UnRead = False
Next
end if
Set objInbox = Nothing
Set objnSpace = Nothing
Set objSubfolder = Nothing
Set unreadItems = Nothing
End Sub
This question already has answers here:
How can I compare all the titles of all RSS feeds and delete duplicates?
(2 answers)
Closed 5 years ago.
I'm wondering if there is a way to compare ALL TITLES in ALL RSS FEEDS and delete the duplicates.
I read through a lot of RSS Feeds, and it's obvious that a lot of people cross-post to several forums, and then I end up seeing the same RSS Feed multiple times.
I really just want to see each one one single time. Is there a way to list all feeds, and delete duplicates, if I actually have duplicates in my entire MS Outlook RSS Feed list?
Here's 0m3r's script, modified slightly.
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Dim Item As Object
Dim Items As Items
Dim DupItem As Object
Dim i As Long
Dim j As Long
For j = 1 To 21
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds).Folders(j)
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = RSS_Folder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.Subject) Then
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
Item.Delete
Else
'Debug.Print Item.Subject
DupItem.Add Item.Subject, 0
End If
End If
Next i
Debug.Print RSS_Folder
Next j
Set olNs = Nothing
Set RSS_Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
Iterating over all items in the folder is not really a good idea.
For Each myItem In subFolder.Items
If InStr(myItem.Subject, "[on hold]") > 0 Then
You can use the Find/FindNext or Restrict methods of the Items class to find all items that correspond to your conditions. Read more about them in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may find the AdvancedSearch method of the Application class helpful.
The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
Finally, you can stop the search process at any moment using the Stop method of the Search class.
Read more about that in the Advanced search in Outlook programmatically: C#, VB.NET article.
Work with Dictionary Object to compare Items.Subject in your olFolderRssFeeds
Dictionary in VBA is a collection-object:
you can store all kinds of things in it: numbers, texts, dates, arrays, ranges, variables and objects, Every item in a Dictionary gets its own unique key and
With that key you can get direct access to the item (reading/writing).
Here is quick Example code
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Dim Item As Object
Dim Items As Items
Dim DupItem As Object
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds) _
.Folders("Microsoft At Home")
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = RSS_Folder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.subject) Then
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
' Item.Delete
Else
DupItem.Add Item.subject, 0
End If
End If
Next i
Set olNs = Nothing
Set RSS_Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
This Example shows how to process all Folders under RSS Feed Folders
Option Explicit
Public Sub DupeRSS()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds)
' // Process Current Folder
Example RSS_Folder
End Sub
Public Sub Example(ByVal ParentFolder As Outlook.MAPIFolder)
Dim Folder As Outlook.MAPIFolder
Dim Item As Object
Dim DupItem As Object
Dim Items As Items
Dim i As Long
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = ParentFolder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.subject) Then
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
Item.Delete
Else
DupItem.Add Item.subject, 0
End If
End If
Next i
' // Recurse through subfolders
If ParentFolder.Folders.Count > 0 Then
For Each Folder In ParentFolder.Folders
Example Folder
Debug.Print Folder.Name
Next
End If
Set Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
Remember the code will only compare duplicate in single folder
I want to search ALL my outlook for latest message in a conversation (I use Subject name as search key).
This latest message can be in Inbox, Sent Items, in a sub folder of Inbox, a sub-sub folder of Inbox (anywhere).
I can achieve this by some very tedious code, going through every level of each major folder, but not only this method is very messy, I can't determine if this found message is the latest in this conversation.
I have the following code, which
--> Searches Inbox for "searchKey"
--> If finds it in Inbox folder, replies to it
--> If not, it moves into subfolders of Inbox, and continues the same process
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olFldr As MAPIFolder
Dim olMail ' As Outlook.MailItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set olFldr = Fldr
tryAgain:
For Each olMail In olFldr.Items
If InStr(olMail.Subject, searchKey) <> 0 Then
Set ReplyAll = olMail.ReplyAll
With ReplyAll
.HTMLBody = Msg & .HTMLBody
emailReady = True
.Display
End With
End If
Next olMail
If Not emailReady Then
i = i + 1
If i > Fldr.Folders.Count Then
MsgBox ("The email with the given subject line was not found!")
Exit Sub
Else
Set olFldr = Fldr.Folders(i)
GoTo tryAgain
End If
End If
This code might be confusing and long, so please let me know if you need any clarification.
The question is: How can I search through ALL Outlook, without going manually through every folder/subfolder/sub-subfolder... without this method, and find the LAST message in a specific conversation? Or, at least, how can I optimize this code so I don't miss any folder, and know the dates and times these emails were sent?
You can use the built in AdvancedSearch function, which returns a Search object containing items.
These should have date properties, so you only need your code to go through the search object mailItems and find that with the latest date ( ReceivedTime)?
I would suggest using the bottom example on that page - it gets a table object from the search, and then you use
Set MyTable = MySearch.GetTable
Do Until MyTable.EndOfTable
Set nextRow = MyTable.GetNextRow()
Debug.Print nextRow("ReceivedTime")
Loop
From there, you can do the comparison to find the latest time, and if you want to do something with the mailitem you would need to obtain the "EntryID" column from the table.
Then use the GetItemFromID method of the NameSpace object to obtain a full item, since the table returns readonly objects.
You can also apply a date filter to the search if you wish, if you knew a minimum date for instance.
To go through all folders do this:
Go once through all the primary folders in Outlook and then for each major folder go through each subfolder. If you have more branches then is guess you have to add more levels to the code "for each Folder3 in folder2.folders". Also in the if clause you can test the date of the mail and go from the newest to the oldest. Set oMsg.display to see what mail is being checked
Public Sub FORWARD_Mail_STAT_IN()
Dim Session As Outlook.NameSpace
Dim oOutLookObject As New Outlook.Application
Dim olNameSpace As NameSpace
Dim oItem As Object
Dim oMsg As Object
Dim searchkey As String
Set oOutLookObject = CreateObject("Outlook.Application")
Set oItem = oOutLookObject.CreateItem(0)
Set olNameSpace = oOutLookObject.GetNamespace("MAPI")
Set Session = Application.Session
Set Folders = Session.Folders
For Each Folder In Folders 'main folders in Outlook
xxx = Folder.Name
For Each Folder2 In Folder.Folders 'all the subfolders from a main folder
yyy = Folder2.Name
Set oFolder = olNameSpace.Folders(xxx).Folders(yyy) 'in each folder we search all the emails
For Z = oFolder.Items.Count To 1 Step -1 ' For Z = 1 To oFolder.Items.Count
With oFolder.Items(Z)
Set oMsg = oFolder.Items(Z)
If Format(oMsg.SentOn, "mm/dd/yyyy") = Format(Date, "mm/dd/yyyy") And InStr(1, LCase(oMsg.Subject), searchkey, vbTextCompare) > 0 Then
oMsg.display
' insert code
End If
End With
Next Z
Next Folder2
Next Folder
I have set up a macro in Outlook and it was working however in the last few days it has stopped filing received emails to specific folders and comes up with a Run Time Error 438 Object doesn't support this property or method error
First the code:
Dim ns As Outlook.NameSpace
Dim objItem As Object
Dim FolderInbox As Folder
Dim MyItem As Outlook.MailItem
'// Added - A collection to hold the IDs of message to be deleted
Dim cMAILS As Collection
Set ns = Application.GetNamespace("MAPI")
Set FolderInbox = ns.GetDefaultFolder(olFolderInbox)
Set cMAILS = New Collection
For Each objItem In FolderInbox.Items
' here is the error
If objItem.ReceivedTime < Now - 50 And objItem.FlagStatus = 1 Then
' Here is a series of code in place
' to move copies of messages to different folder
Next
On Error Resume Next
Do While cMAILS.Count > 0
Set MyItem = ns.GetItemFromID(cMAILS(1))
If Not MyItem Is Nothing Then
MyItem.Delete
End If
cMAILS.Remove (1)
Loop
The line with the error is:
If objItem.ReceivedTime < Now - 50 And objItem.FlagStatus = 1 Then
Test that each object is a mailitem, because if not they might not have ReceivedTime or Flagstatus. Try something like:
If TypeOf objItem Is MailItem Then
If objItem.ReceivedTime < Now - 50 And objItem.FlagStatus = 1 Then
...
I am trying to delete all emails in my inbox that are older than 90 days. I am not able to use the auto archive since it has been disabled at my office. I have some code that does not seem to be deleting every mail that is older than 90 days. I think the issue might be with my loop. I am using Outlook 2010 with exchange 2010.
Private Sub RemoveEmail90()
Dim olSession As Outlook.Application, olNamespace As NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim i As Integer
Set olSession = New Outlook.Application
Set olNamespace = olSession.GetNamespace("MAPI")
Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)
Set Delete_Items = olInbox.Items
For i = Delete_Items.Count To 1 Step -1
If TypeName(Delete_Items.Item(i)) = "MailItem" Then
If DateDiff("d",now, Delete_Items.Item(i).ReceivedTime) > 90 Then Delete_Items.Item(i).Delete
End If
Next
Set olSession = Nothing
Set olNamespace = Nothing
Set olInbox = Nothing
End Sub
I was able to fix it by tweaking the code. Now the code runs just fine. I change the "m" on line 13 to a "d" and now it is deleting all older emails. Updated code Above.
If DateDiff("d",now, Delete_Items.Item(i).ReceivedTime) > 90 Then Delete_Items.Item(i).Delete