I wish to create a VBA program to remove items within the Deleted Items folder of my outlook. However, I only wish to remove such items from the certain users through matching a loose string.
For example, deleting all emails within the Deleted Items box from any user with address like "Plan_Group_", given I may receive emails from "Plan_Group_1", "Plan_Group_2","Plan_Group_3",...etc.
At present this is what I have for deletion, but it is for all items within the Deleted Items box:
Sub RemoveAutomaticItemsInDeletedItems()
Dim oDeletedItems As Outlook.Folder
Dim oItems As Outlook.Items
Dim i As Long
'Obtain a reference to deleted items folder
Set oDeletedItems = Application.Session.GetDefaultFolder(olFolderDeletedItems)
Set oItems = oDeletedItems.Items
For i = oItems.Count To 1 Step -1
oItems.Item(i).Delete
Next
End Sub
How can I extend this to only look for emails that loosely match a from address string?
Use an If statement to check the email address:
If TypeName(oItems.Item(i)) = "MailItem" And oItems(i).SenderEmailAddress Like "Plan_Group_*" Then
oItems.Item(i).Delete
End If
Or:
If TypeName(oItems.Item(i)) = "MailItem" And Left$(oItems(i).SenderEmailAddress, 11) = "Plan_Group_" Then
oItems.Item(i).Delete
End If
Just 2 ways of doing it
Related
At work we send emails from Shared Inboxes. The emails would go into the user's own Sent Items instead of that of the Shared Inbox.
I wrote some VBA code which sorted this issue. We are moving to Outlook 365 & the code is not working there.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) = "MailItem" Then 'If Item is a MailItem
If Item.SentOnBehalfOfName <> "" Then 'And if Item is Sent on Behalf of an inbox
'Save the sent email in the Sent Items folder for the inbox in question
Item.SaveSentMessageFolder GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items")
End If
End If
End Sub
I tried
msgbox GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items").Name
It gives the name of the folder but the Sent Item does not go there.
I created a "Test" folder & saved to the folder ignoring Item.SentOnBehalfOfName & this works if the "Test" folder is in my own inbox but not if it is in a Shared Inbox.
I tried changing the code to use Set & to include Application as per below.
Set Item.SaveSentMessageFolder = Application.GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items")
You can set a folder from a single store, there is no way to set a folder from another store/account. If you want to get items saved to another store, you must save them first and then move them programmatically to another folder/store.
Also, I'd suggest setting the MailItem.SaveSentMessageFolder property before an item is submitted:
Sub SetSentFolder()
Dim myItem As Outlook.MailITem
Dim myResponse As Outlook.MailITem
Dim mpfInbox As Outlook.Folder
Dim mpf As Outlook.Folder
Set mpfInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set mpf = mpfInbox.Folders.Add("SaveMyPersonalItems")
Set myItem = Application.ActiveInspector.CurrentItem
Set myResponse = myItem.Reply
myResponse.Display
myResponse.To = "Eugene Astafiev"
Set myResponse.SaveSentMessageFolder = mpf
myResponse.Send
End Sub
In the ThisOutlookSession module add the following variable declaration:
Private WithEvents Items As Outlook.Items
If you don't already have an Application_Startup event procedure create it by selecting Application in the left dropdown over the code area & Startup in the right dropdown over the code area.
The code to add to this procedure:
Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
Then in the left dropdown over the code area you need to select Items & in the right dropdown over the code area select ItemSend.
Below is what this procedure should look like:
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeName(Item) = "MailItem" Then 'If Item is a MailItem
If Item.SentOnBehalfOfName <> Session.Accounts.Item(1).CurrentUser Then 'And if Item is Sent on Behalf of the users own inbox
'Move the email into the Sent Items folder for the inbox in question
Item.Move GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items")
End If
End If
End Sub
I'd like to list all of my emails in a specific folder by using Outlook MAPI. I have tried the following code,
but it only shows 400 out of the 20,000 emails in the folder. I would greatly appreciate it if anyone could please show me how to list all of the emails.
Sub EmailListinFolder()
Dim mn As Long
Dim Message As String
Dim item As Object
Dim NS As Object
Dim Folder As Object
'Get the MAPI Name Space
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
'Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder
For Each item In Folder.Items
If item.Class = olMail Then
Message = item.Subject & "|" & item.CreationTime
If Len(Message) Then
mn = mn + 1
End If
End If
Next item
MsgBox (mn)
End Sub
Is that an online profile? Most likely you end up opening too many items (for each loop keeps all items referenced until the loop exits). Use Table object instead - see example at https://msdn.microsoft.com/VBA/Outlook-VBA/articles/folder-gettable-method-outlook.
I am writing a simply script to delete all calendar objects within the Deleted Items folder. such calendar objects include meeting confirmations, declines...etc.
At present I have below, does not delete anything, even though checking the deleted items folder has many calendar confirmations, declines..etc:
Dim oDeletedItems As Outlook.Folder
Dim obj As Outlook.MailItem
Dim i As Integer
'Obtain a reference to deleted items folder
Set oDeletedItems = Application.Session.GetDefaultFolder(olFolderDeletedItems)
For i = oDeletedItems.Items.Count - 1 To 1 Step -1
' Delete all appointment items
If oDeletedItems.Items(i).Class = AppointmentItem Then
'Debug.Print obj.Subject
oDeletedItems.Items.Item(i).Delete
End If
Next
Firstly, do not use multiple dot notation (oDeletedItems.Items(i).Class) - cache the Items collection before entering the loop.
Secondly, confirmations, declines, etc. are meeting items, not appointments.
Thirdly, Class property returns one of the OlObjectClass enum values. AppointmentItem is an item type (interface).
You need to use 53 (olMeetingRequest) or 26 (olAppointment).
Fourthly, start the loop from Items.Count, not Items.Count-1.
set items = oDeletedItems.Items
For i = items.Count To 1 Step -1
' Delete all appointment items
set item = items.Item(I)
itemClass = item.Class
If (itemClass= olAppointment) or (itemClass= olMeetingRequest) Then
'Debug.Print obj.Subject
item.Delete
End If
Next
I am connected to my company's MS Exchange. From my own Outlook profile, I access a generic mailbox. All incoming messages will be tagged to a category and then moved to a folder (Mailbox - Generic > Resolved). How can I generate a total count of each category in this folder?
Mailbox - Javen
Inbox
Sent Items
...
Mailbox - Generic
Inbox
Sent Items
Resolved
...
Each category will be named to a name...
Example: Red = John, Yellow = Peter, Purple = Peggy
This should get you going. It filters the folder a specified category. You can edit it to do loop of the Outlook Categories collection to get the counts. Or you could change it to be a function that returns the count...passing the Category name as a parameter.
Private Sub CountbyCategory()
Dim fldr As Outlook.Folder = Nothing
Dim itms As Outlook.Items = Nothing
Dim filteredItms As Outlook.Items = Nothing
'Do this for each category...
Dim typeFilter As String = "[Category] = " & Chr(39) & "INSERT CATEGORY NAME HERE" & Chr(39)
'This assumes default inbox, you'll need to select you folder...maybe use PickFolder?
'fldr = Application.Session.PickFolder()
fldr = Application.Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
itms = fldr.Items
filteredItms = itms.Restrict(typeFilter)
Dim iCount As Integer = filteredItms.Count
'Repeat for each category
End Sub
You can learn more about working with Outlook items here:
Working with Outlook mail items: how to create, delete, access & enumerate
Working with Outlook Accounts, Stores, Folders and Items
I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub