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
Related
I've had an Outlook 2016 VBA macro running for a year to check emails arriving in my inbox. Today, following installation of Windows 10 updates, I get a type mismatch error when this macro runs. The error line is the Set olNs = Application.GetNamespace("MAPI") line below:
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim olRecip As Recipient
Dim dt As String
Dim strFile_Path As String
dt = Format(CStr(Now), "yyyy_mmm_dd_hh_mm")
strFile_Path = "d:\temp\parking.log"
Open strFile_Path For Append As #1
Write #1, dt & " " & "Application_Startup() triggered"
Close #1
Set olNs = Application.GetNamespace("MAPI")
Set olRecip = olNs.CreateRecipient("me#gmail.com")
Set Inbox = olNs.Folders("me#gmail.com").Folders("Inbox")
Set Items = Inbox.Items
End Sub
Any idea how I can fix this?
First of all, you need to make sure the COM references are set correctly.
You may try to run the code without setting a local variable:
Private Sub Application_Startup()
MsgBox "Welcome, " & Application.GetNamespace("MAPI").CurrentUser
Application.ActiveExplorer.WindowState = olMaximized
End Sub
I just ran into this issue (COM add-ins were fine) and as stated, removing the explicit declaration seems to fix the issue (you can also Dim the Namespace as an Object instead of Outlook.Namespace).
As a quick reference for anyone else I used the following code to bypass the issue:
With Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = .GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = .GetDefaultFolder(olFolderJunk)
End With
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
How do I automatically send out multiple (currently visible) draft items with VBA?
Please help, thank you.
Edit: It's a tough case, none of the items are in the drafts folder yet. These are generated emails that are on your screen, waiting to be sent.
Edit2: nvm, it's not going to help anyway. My script creates approximately 500 emails, and displaying the first 100 causes out of memory error. I opted to auto send them without displaying (it breaks the layout this way, but it's my only option for now.)
It just so happens that I ran into the same issue before and have code handy. If you're not already in Outlook, you will need to add a reference in the VBA IDE, Tools ---> References... and check the box next to "Microsoft Outlook 14.0 Object Library".
Dim oFolder As Folder
Dim oNS As NameSpace
Dim olMail As MailItem
If (MsgBox("Are you sure you want to send ALL EMAILS IN YOUR DRAFTS FOLDER?", vbYesNo + vbCritical, "WARNING: THIS WILL SEND ALL DRAFTS")) = vbYes Then
Set oNS = Outlook.Application.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderDrafts)
For i = 1 To oFolder.Items.Count
oFolder.Items(1).Send
Next
End If
Set oNS = Nothing
Here's some code. Replace Your Name in myFolders("Mailbox - Your Name") with your actual name as it appears in the mailbox.
Public Sub EmailOutlookDraftsMessages()
Dim lDraftItem As Long
Dim myOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolders As Outlook.Folders
Dim myDraftsFolder As Outlook.MAPIFolder
'Send all items in the "Drafts" folder that have a "To" address filled in.
'Setup Outlook
Set myOutlook = Outlook.Application
Set myNameSpace = myOutlook.GetNamespace("MAPI")
Set myFolders = myNameSpace.Folders
'Set Draft Folder.
Set myDraftsFolder = myFolders("Mailbox - Your Name").Folders("Drafts")
'Loop through all Draft Items
For lDraftItem = myDraftsFolder.Items.Count To 1 Step -1
'Check for "To" address and only send if "To" is filled in.
If Len(Trim(myDraftsFolder.Items.Item(lDraftItem).To)) > 0 Then
'Send Item
myDraftsFolder.Items.Item(lDraftItem).Send
End If
Next lDraftItem
'Clean-up
Set myDraftsFolder = Nothing
Set myNameSpace = Nothing
Set myOutlook = Nothing
End Sub
Source Code adapted from this Question's answer.
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.
I copied the following code in my oulook VBE, from one of the VBA communities and amended it as per my need.
I can run it using F5 and F8. Now I would like to run this macro whenever I receive an email in folder1.
I tried setting up a rule but I cannot see the macro listed in the 'run a script' selection box.
I have already checked that
macro security setting are correct
macro is in a module not in a class
can you please tell me what is going wrong in the setting.
Public Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim yourFolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim I As Long
Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set yourFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myFolder = myFolder.Folders("folder1")
Set yourFolder = yourFolder.Folders("folder2")
For Each myItem In myFolder.Items
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
I = I + 1
myAttachment.SaveAsFile "C:\arthur\test.csv"
Next
End If
myItem.Move yourFolder
Next
End Sub
To be recognized as proper script macro for the Rule Wizard, the macro has to have the expected parameter:
Sub myRuleMacro(item as Outlook.MailItem)
MSDN article (still valid for Outlook 2007/2010/2013/2016)
Related article
Article about enabling run-a-script rules otherwise disabled due to security reasons
(registry key EnableUnsafeClientMailRules).
I had the same issue today on a similar script after Office was upgraded to Version 1803 (Build 9126.2282). Removing the "Pubic" keyword from the sub did the trick. Not sure why, since has been working the other way for years.
I also had to re-add the reg key that had disappeared - EnableUnsafeClientMailRules.