Move specific mails from one folder to another - vba

in Outlook I would like to have a FollowUp-Solution that checks a specific folder (Source Folder) if there are mails older than 1 days and moves them in another specific folder (Target Folder).
My problem is that it seems as my code isn't looping the SourceFolder properly. Some mails are moved but some old mails are still in the SourceFolder.
When I restart the Code some of the remaining mails are moved now but still some remain in the SourceFolder.
I tried to loop the Items in other ways (with; for each; do) but I guess my vba understanding is too bad to get a working solution.
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim Item As Object
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Set FolderItems = FolderSource.Items
For Each Item In FolderItems
If Item.ReceivedTime < Date - 1 Then '
Item.Move FolderTarget
End If
Next
End Sub
Does anyone know how to handle the propper looping?

For Each Loop is a great but When moving/deleting items Loop Through in Reverse Order you know count down (ie 3,2,1). In order to do this, you can incorporate Step -1 into your loop statement.
Also to improve your loop try using Items.Restrict Method (Outlook) on your date filter
Example
Option Explicit
Sub MoveFollowUpItems()
Dim FolderTarget As Folder
Dim FolderSource As Folder
Dim FolderItems As Outlook.Items
Set FolderTarget = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set FolderSource = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("FollowUp")
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " <= 'Date - 1' "
Set FolderItems = FolderSource.Items.Restrict(Filter)
Debug.Print FolderItems.Count
Dim i As Long
For i = FolderItems.Count To 1 Step -1
Debug.Print FolderItems(i) 'Immediate Window
' FolderItems(i).Move FolderTarget
Next
End Sub

Related

430 Error on Date - itm.ReceivedTime in a subfolder

I get a 430 error running code on a subfolder of a shared inbox.
Sub GetEmails()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Const NUM_DAYS As Long = 34
Dim OutlookApp As Outlook.Application
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
Dim mailboxName As String, inboxName As String, subfolderName As String
mailboxName = "mailboxname"
inboxName = "Inbox"
subfolderName = "subfoldername"
Set OutlookApp = New Outlook.Application
On Error Resume Next
Set Folder = OutlookApp.Session.Folders(mailboxName) _
.Folders(inboxName).Folders(subfolderName)
On Error GoTo 0
If Folder Is Nothing Then
MsgBox "Source folder not found!", vbExclamation, _
"Problem with export"
Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(1)
'add headers
ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
iRow = 2
Folder.Items.Sort "Received"
For Each itm In Folder.Items
If TypeOf itm Is Outlook.MailItem Then 'check it's a mail item (not appointment, etc)
If Date - itm.ReceivedTime <= NUM_DAYS Then
sBody = Left(Trim(itm.Body), 150) 'first 150 chars of Body
sBody = Replace(sBody, vbCrLf, "; ") 'remove newlines
sBody = Replace(sBody, vbLf, "; ")
ws.Cells(iRow, 1).Resize(1, 4).Value = _
Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
iRow = iRow + 1
End If
End If
Next itm
MsgBox "Outlook Mails Extracted to Excel"
End Sub
I tried changing "itm" to "item". It works on the regular inbox. The issue happens when I try to pull from a subfolder.
I tried Debug Print. I don't know if I'm putting it in the right place.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
If I try to pull 30 days worth of data, it will only pull like the last seven days. So it works but it is limited.
First of all, the Sort method deals with non-existsing property:
Folder.Items.Sort "Received"
You need to use the ReceivedTime property instead.
Second, the sorted collection is lost and you continue dealing with unsorted one.
Folder.Items.Sort "Received"
For Each itm In Folder.Items
Asking each time the Items property returns a new Items instance. So, you need to get an instance once and then re-use in the code. Only by following this way you will preserve the sorting order.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
The error code indicates that Class doesn't support Automation (Error 430) which don't tell us anything meaningful.
Anyway, calculating dates that way to get items for specific dates in Outlook is not the best and proper way. Instead, you need to consider using the Find/FindNext or Restrict methods of the Items class which allows getting/dealing with items that correspond to your conditions only. Read more about these methods in the articles I wrote for the technical blog:
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
For example, you could use the following search criteria to get items for a specific timeframe:
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.

How to verify a mail from today exist?

I want to see if an email exists in a particular Outlook folder, using Excel VBA.
Sub Get_Calls_MTD_Data()
'making sure windows not jumping forth and back
Application.ScreenUpdating = False
Dim getCalls As Workbook
Dim releaseCalls As Workbook
Dim fPat As String
fPat = ThisWorkbook.Path
Dim SNDate As String
'The sheetname gets the date for the day name, so using variable for that
SNDate = Date
'-------------------
'Error handling doesn't work
'this dosent work any longer?
'If Dir(fPat & "\Outlookdata\calls mtd\" & Date & "." & "***") = "" Then
'
' MsgBox "does not find mail"
'
'Else
' making sure the windows dosen jump forth and back and no alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---------------------------
Set getCalls = Workbooks.Open(fPat & "\Outlookdata\Calls mtd\" & Date & "." & "*")
Set releaseCalls = Workbooks.Open(fPat & "\" & ThisWorkbook.Name)
getCalls.Activate
If Not IsEmpty(Range("G2").Value) = True Then
'finding last row
mylastagent = getCalls.Sheets(SNDate).Cells(Rows.Count, "G").End(xlUp).Row
getCalls.Sheets(SNDate).Range("G2:H" & mylastagent).Copy
releaseCalls.Activate
releaseCalls.Sheets("calls").Range("A1").PasteSpecial xlPasteValues
End If
getCalls.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("M3").Select
Update_Day_When_Calls_Updates
'Just the end if for the faulty error handling in the top
' End If
End Sub
Do I have to loop through the folder to find an email from today?
Also I started to get the prompt "clipboard has too much information, do you want to save it" in the end. Tried here for instance:
Disable clipboard prompt in Excel VBA on workbook close
Don't use strict date checks in Outlook. Instead, you need to use the Find/FindNext or Restrict methods of the Items class that allows getting only items that correspond to the search criteria. In the search criteria I'd recommend using less or greater conditions for dates.
Outlook evaluates date-time values according to the time format, short date format, and long date format settings in the Regional and Language Options applet in the Windows Control Panel. In particular, Outlook evaluates time according to that specified time format without seconds. If you specify seconds in the date-time comparison string, the filter will not operate as expected.
Although dates and times are typically stored with a date format, filters using the Jet and DAV Searching and Locating (DASL) syntax require that the date-time value to be converted to a string representation. In Jet syntax, the date-time comparison string should be enclosed in either double quotes or single quotes. In DASL syntax, the date-time comparison string should be enclosed in single quotes.
To make sure that the date-time comparison string is formatted as Microsoft Outlook expects, use the Visual Basic for Applications Format function (or its equivalent in your programming language).
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.
Read more about the Find/FindNext and Restrict methods in the articles I wrote for the technical blog:
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
If you need to search for items in multiple folders you may consider using the AdvancedSearch method of the Application class, see Advanced search in Outlook programmatically: C#, VB.NET.
In the case of "today's mail", if processing time is noticeable, you can .Sort then stop processing once older mail is found.
Option Explicit
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
' Where code is not in Outlook
' Reference Microsoft Outlook nn.n Object Library
Dim ol As Outlook.Application
Dim fol As Outlook.Folder
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set fol = Session.Folders("Random#Email.com")
Set fol = fol.Folders("OutlookData")
Set fol = fol.Folders("Calls Daily")
Dim folItems As Items
Set folItems = fol.Items
folItems.Sort "[ReceivedTime]", True
Dim j As Long
For j = 1 To folItems.Count
If folItems(j).Class = olMail Then
Set mi = folItems(j)
If mi.Attachments.count > 1 Then
If Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
Debug.Print mi.Subject
Debug.Print " " & Format(mi.ReceivedTime, "yyyy-mm-dd")
Else
'Older mail
Exit For
End If
End If
End If
Next
End Sub
.Restrict and .Find could be applied to all cases.
I managed to do it like this, probably not the best way, no certainly not the best way, but i solved it for my needs :) Thanks Niton.
Public RecivedToday As String
Sub Check_If_Mail_From_Today_Exists_Calls_Daily()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.folder
Dim i As Object
Dim mi As Outlook.MailItem
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("Random#Email.com").Folders("OutlookData").Folders("Calls Daily")
For Each i In fol.Items
If i.Class = olMail Then
Set mi = i
If mi.Attachments.Count > 1 And Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
'Debug.Print Format(mi.ReceivedTime, "yyyy-mm-dd")
RecivedToday = Format(Date, "yyyy-mm-dd")
'Debug.Print RecivedToday
End If
End If
Next i
End Sub

Outlook template rule to sort mails among directories

I have folders created for different projects (e.g. Proj1, Proj2, Proj3, ...).
It is general convention in the department to sent emails concerning specific project with its name in the subject (e.g. "Proj1: project finished!").
I know that I can create rules for every project to move mails that contain its name to the project folder. However, I would need to create as many rules as the number of folders I have - so its not very convenient and optimal.
Is there any way to create a rule (a single rule) (possibly, with VBA code) that will contain list of all folder names, search for any name from the list among mails' subjucts and automatically move mail to the corresponding folder?
In order to achieve exactly what you want you can use this macro:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder
For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
If m.Subject Like "*" & fldr.Name & "*" Then m.Move fldr
Next
Set fldr = Nothing
End Sub
This macro can be triggered by arrival of a new email if you add to ThisOutlookSession module these lines:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim o As Object
Set o = Application.Session.GetItemFromID(EntryIDCollection)
If TypeName(o) = "MailItem" Then RulesForFolders o
Set o = Nothing
End Sub
Though, I would recommend you get rid of the folders where you move your messages to. Instead, you can use keep all you messages in Inbox and use Search folders to group them in whatever order you want. This way you can quickly search through all your inbox and sort it as well as separate search folders. You can also have the same message in different folders not duplicating it. If you decide to do so, your macro will need to assign categories instead of moving messages:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder, str As Outlook.Store
For Each str In Application.Session.Stores
For Each fldr In str.GetSearchFolders
If m.Subject Like "*" & fldr.Name & "*" Then
m.Categories = m.Categories & "," & fldr.Name
m.Save
End If
Next
Next
Set fldr = Nothing
Set str = Nothing
End Sub
I needed the rule to process subfolders, so I have slightly modified the previous answer of #Vladislav Andreev:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder
For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
If LCase(m.Subject) Like "*" & LCase(fldr.Name) & "*" Then
m.Move fldr
Exit For
End If
For Each subFldr In fldr.Folders
If LCase(m.Subject) Like "*" & LCase(subFldr.Name) & "*" Then
m.Move subFldr
Exit For
End If
Next
Next
Set fldr = Nothing
Set subFldr = Nothing
End Sub

Excel VBA - leave 5 newest backups and delete the rest

I have a macro in excel that runs before save and creates a backup of an excel table with the actual date in its name.
These backups started to take too much space, so I have inserted another macro that deletes backups older than 14 days. The problem is that sometimes we don't save new copies for 2 weeks or months, so I need a macro that will leave only the 5 newest backups and delete the rest.
The current macro used:
'======================================================================================
'delete old backup
Set fso = CreateObject("Scripting.FileSystemObject")
For Each fcount In fso.GetFolder(ThisWorkbook.Path & "\" & "excel_backups" & "\").Files
If DateDiff("d", fcount.DateCreated, Now()) > 14 Then
Kill fcount
End If
Next fcount
'======================================================================================
backups are saved in this format:
ThisWorkbook.Path & "\excel_backups" & "\backup_" & Format(Date, "yyyy.mm.dd") & ".h" & Hour(Now) & "_" & ActiveWorkbook.name
so a backup looks like this: backup_2014.12.18.h14_[filename].xlsm
My question is: can this be modified somehow to delete only the oldest ones, and leave the last 5 newest of them? I have no idea how to start writing that.
Thank you for your time.
This may not be the most efficient way but it seems to work as a starting point.
Sub DeleteBackups()
Dim fso As Object
Dim fcount As Object
Dim collection As New collection
Dim obj As Variant
Dim i As Long
Set fso = CreateObject("Scripting.FileSystemObject")
'add each file to a collection
For Each fcount In fso.GetFolder(ThisWorkbook.Path & "\" & "excel_backups" & "\").Files
collection.Add fcount
Next fcount
'sort the collection descending using the CreatedDate
Set collection = SortCollectionDesc(collection)
'kill items from index 6 onwards
For i = 6 To collection.Count
Kill collection(i)
Next i
End Sub
Function SortCollectionDesc(collection As collection)
'Sort collection descending by datecreated using standard bubble sort
Dim coll As New collection
Set coll = collection
Dim i As Long, j As Long
Dim vTemp As Object
'Two loops to bubble sort
For i = 1 To coll.Count - 1
For j = i + 1 To coll.Count
If coll(i).datecreated < coll(j).datecreated Then
'store the lesser item
Set vTemp = coll(j)
'remove the lesser item
coll.Remove j
're-add the lesser item before the greater Item
coll.Add Item:=vTemp, before:=i
Set vTemp = Nothing
End If
Next j
Next i
Set SortCollectionDesc = coll
End Function
Here's what I came up with. It counts the number of files in your backup folder (handy!), calls them out one by one and keeps track of which is the oldest, and finally forcibly deletes the oldest. It does this until there are fewer than six remaining.
Sub DeleteOldFiles()
Dim fso As New FileSystemObject
Dim fil As File
Dim oldfile As File
Dim BackUpPath As String 'This is the FOLDER where your backups are stored
Do Until fso.GetFolder(BackUpPath).Files.Count < 6
For Each fil In fso.GetFolder(BackUpPath).Files
'Checks to see if this file is older than the oldest file thus far
If oldfile Is Nothing Then Set oldfile = fil
If oldfile.DateLastModified > fil.DateLastModified Then Set oldfile = fil
Next fil
fso.DeleteFile oldfile, True
Set oldfile = Nothing
Loop
End Sub
I like this because you don't have to worry what the names are and it's probably marginally quicker than sorting (which shouldn't matter for five files).
One caveat: it requires the scrrun.dll library. The reference is called (in MS Office 2013) Microsoft Scripting Runtime. The FileSystemObject and its associated properties and methods come from this library.
Also, there is a FileSystemObject.CopyFile method that comes with scrrun.dll.
All this will probably also work with CreateObject("Scripting.FileSystemObject") as well, after some variable changes, but I haven't tested it.

For Each loop: Just deletes the very first attachment

I've been trying to delete the attachments in Outlook after copying them using for each loop. It just deletes the very first attachment after copying it but does not go for the second attachment to work on! It just goes down to the End Sub.
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
'If (Msg.SenderName = "Name Of Person") And _
'(Msg.Subject = "Subject to Find") And _
'(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim olAttch As Outlook.Attachment
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Users\pkshahbazi\Documents\EmailAttachments\"
Set myAttachments = Msg.Attachments
For Each olAttch In myAttachments
Att = olAttch.DisplayName
If Right(olAttch.FileName, 3) = "zip" Then
olAttch.SaveAsFile attPath & Att
olAttch.Delete
End If
Next olAttch
Msg.UnRead = False
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I figured out that the OlAttch.delete statement confuses the For Each loop.
Any idea how I can delete the attachments.
In your previous question we changed from an indexed loop to a non-indexed loop, because you did not have any .Delete requirement. Unfortunately, deleting items from a collection requires an indexed iteration.
This is because, when you have 3 items:
Item 1 = Attachment 1
Item 2 = Attachment 2
Item 3 = Attachment 3
Then when you delete the first item (Item 1/Attachment 1), it takes you to item 2, but when the delete happens, you are left with the collection that looks like:
Item 1 = Attachment 2
Item 2 = Attachment 3
So your loop will delete items 1 and 3, but it will never touch item 2.
The simplest way to fix this for you, without using an indexed loop and re-writing your script, is to just add another loop to do the delete method.
#Enderland provides the example for this. I will not duplicate his effort, but I did want to explain what is happening for you. This is always the case when deleting items from a collection, you have to step through the collection in reverse order.
Try this. I added code/comments to iterate through and remove all the attachments after you do your saving. The reasons you should do this are explained very well here by David Zemens.
You also should get in the habit of saving messages you modify in Outlook VBA as sometimes this is important, sometimes it's not, but it can confuse the heck out of you if you don't use Save when you need to.
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Users\pkshahbazi\Documents\EmailAttachments\"
Set myAttachments = Msg.Attachments
For Each olAttch In myAttachments
Att = olAttch.DisplayName
If Right(olAttch.FileName, 3) = "zip" Then
olAttch.SaveAsFile attPath & Att
'olAttch.Delete
End If
Next olAttch
'iterate through all attachments, going backwards
dim j as integer
For j = Msg.Attachments.Count To 1 Step -1
Msg.Attachments.Remove (j)
Next j
'make sure to save your message after this
Msg.save
Msg.UnRead = False
End If