I'm new to Outlook VBA and having a tough time figuring out how to set my subfolder in the code below. I have been trouble shooting this all day. Not sure what I'm missing.
Sub DeleteOlderThan6months()
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Date6months = DateAdd("d", -1, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
Set oFolder = oFolder.Folders("My#email.com").Folders("Inbox").Folders("Zip Files")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
For i = ItemsOverMonths.Count To 1 Step -1
ItemsOverMonths.Item(i).Delete
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
This should do it, see how i set the subfolder
Option Explicit
Sub DeleteOlderThan6months()
'// Declare variables
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim oItem As Object
Dim i As Long
'// set your inbox and subfolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders("Zip Files")
Date6months = DateAdd("d", -1, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
'// Loop through the Items in the folder backwards
For i = ItemsOverMonths.Count To 1 Step -1
Set oItem = ItemsOverMonths.Item(i)
If TypeOf oItem Is Outlook.MailItem Then
Debug.Print oItem.Subject
oItem.Delete
End If
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
set oFolder = Inbox.Folders.Item("Zip Files")
Related
I try to find email from received time but somethings dont want to work. I dont get any error but the msg is not moving to diff folder
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim myOlApp As New Outlook.Application
Set myNameSpace = Outlook.Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.Folders(user_email).Folders("RXXX")
Set myDestFolder = myInbox.Folders(fDestination)
Set myItems = myInbox.Items
Set myItem = myItems.Find("[ReceivedTime] = '#" + msg_date + "#'")
While TypeName(myItem) <> "Nothing"
MsgBox 1
MoveItems = MoveItems + 1
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
Set myNameSpace = Nothing
Set myInbox = Nothing
Set myItems = Nothing
Set myDestFolder = Nothing
Set myItem = Nothing
Format seems correct, but single quotes should not be present:
Set myItem = myItems.Find("[ReceivedTime] = #" + msg_date + "#")
You should never use = when working with DateTime properties - the condition will never be satisfied (even if you specify date and time down to the millisecond level) because of the round-off errors. Always use a range
#SQL=(ReceivedTime < '4/17/2020') AND (ReceivedTime > '4/1/2020')
Date format is a major source of problems.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
'
' If desperate declare as variant
Sub findByReceivedTime_DateRange()
Dim myNamespace As Outlook.Namespace
Dim mySourceFolder As Outlook.folder
Dim myDestFolder As Outlook.folder
Dim fDestination As String
Dim myItems As Outlook.items
Dim myItem As Object
Dim msg_dateStart As Date
Dim msg_dateEnd As Date
Dim msg_dateStartStr As String
Dim msg_dateEndStr As String
Dim strFilter As String
Set myNamespace = Outlook.Application.GetNamespace("MAPI")
' mySourceFolder under mailbox, not under inbox
Set mySourceFolder = myNamespace.folders(user_email)
Set mySourceFolder = mySourceFolder.folders("RXXX")
' myDestFolder under mySourceFolder
fDestination = "TestDest"
Set myDestFolder = mySourceFolder.folders(fDestination)
Set myItems = mySourceFolder.items
myItems.sort "[ReceivedTime]", True
Debug.Print myItems(1).ReceivedTime & ": " & myItems(1).Subject
Debug.Print
' Test with a number bigger than 12 for the day to verify date format
' Start of the range
msg_dateStart = Format(#3/26/2020#, "yyyy/mm/dd")
Debug.Print "msg_dateStart...: " & msg_dateStart
msg_dateStartStr = CStr(msg_dateStart)
Debug.Print "msg_dateStartStr: " & msg_dateStartStr
' For a single day, end of the range is the beginning of the next day
msg_dateEnd = Format(#3/27/2020#, "yyyy/mm/dd")
Debug.Print "msg_dateEnd.....: " & msg_dateEnd
msg_dateEndStr = CStr(msg_dateEnd)
Debug.Print "msg_dateEndStr..: " & msg_dateEndStr
strFilter = "[ReceivedTime] > '#" & msg_dateStartStr & "#'"
Debug.Print strFilter
strFilter = strFilter & " AND [ReceivedTime] < '#" & msg_dateEndStr & "#'"
Debug.Print strFilter
Set myItem = myItems.Find(strFilter)
While TypeName(myItem) <> "Nothing"
Debug.Print myItem.Subject
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End Sub
I'm having issues with getting some code to work. I have put it together from code I found and get an error stating the Sub or Function is not defined. I'm new to Outlook VBA and can't figure it out.
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
'Set the folder and items to watch:
'Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)
'Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set objWatchFolder = objNS.Inbox.Folders.Item("Zip Files")
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Date6months = DateAdd("d", 0, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders.Item("Zip Files")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
For i = ItemsOverMonths.Count To 1 Step -1
ItemsOverMonths.Item(i).Delete
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
If anyone can point me in the right direction that would be great.
See the Changes I made and compare it with yours
Option Explicit
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Zip Files")
Set objItems = objWatchFolder.Items
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
DeleteOlderThan6months Item
End If
End Sub
'https://stackoverflow.com/questions/37060954/trouble-setting-the-subfolder
Sub DeleteOlderThan6months(ByVal Item As Object)
'// Declare variables
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim oItem As Object
Dim i As Long
'// set your inbox and subfolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders("Zip Files")
Date6months = DateAdd("d", -1, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
' // Loop through the Items in the folder backwards
For i = ItemsOverMonths.Count To 1 Step -1
Set oItem = ItemsOverMonths.Item(i)
If TypeOf oItem Is Outlook.MailItem Then
Debug.Print oItem.Subject
oItem.Delete
End If
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
Tested on Outlook 2010.
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 the below code which works.
I now need to find the newest email with that subject line and open it.
Once the email is opened, I'd like to save the attachment to my desktop and close out of the opened email.
Sub SearchOL()
Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "DNP Warn and Pend Event") <> 0 Then
olMail.Display
i = i + 1
End If
Next olMail
End Sub
I'd suggest starting from the Getting Started with VBA in Outlook 2010 article in MSDN.
Use the Find/FindNext or Restrict methods of the Items class to find the emails with a particular subject line instead of iterating through each email and checking the subject line.
Sub DemoFindNext()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
While TypeName(currentAppointment) <> "Nothing"
MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub
I'm looking for a VBA code snippet to delete Outlook messages that are six (6) months or older and sit in a user-created folder.
What does that code look like?
Here is a example script
Sub DeleteOlderThan6months()
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Date6months = DateAdd("d", -182, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
Set oFolder = Application.Session.PickFolder 'or set your folder
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
For i = ItemsOverMonths.Count To 1 Step -1
ItemsOverMonths.Item(i).Delete
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub