I am trying to create an Outlook Macro that will analyze the subject of an Inbox folder and decide where to move them to a subfolder or delete them based on a list of keywords for four different categories.
The problem is that the Inbox I am using is not the regular Inbox (I have two different Inbox folders, and this one is not the default one). So I need to target it in a way similar to writing the full path (Example: "\\xxx#xxx.net\Inbox\"). I tried to find an answer to it but all the info I found here relates to the assumption that we are working from the default Inbox.
Sub CountAttachmentsMulti2()
Dim oItem As Object
Dim iAttachments As Integer
For Each oItem In ActiveExplorer.Selection
iAttachments = oItem.Attachments.Count + iAttachments
If oItem.Attachments.Count <> 0 Then 'Si el mensaje contiene adjuntos
NumofItems = oItem.Attachments.Count + NumofItems
For j = 1 To oItem.Attachments.Count
MsgBox oItem.Attachments.Item(j).DisplayName
Value = oItem.Attachments.Item(j).DisplayName
If InStr(LCase(Value), "su") > 0 Then
MsgBox "Clap"
End If
Next j
Else
MsgBox oItem.Subject 'Get Subject Title
NumofItems = NumofItems + 1
End If
Next
MsgBox "Selected " & ActiveExplorer.Selection.Count & " messages with " & iAttachments & " attachements"
MsgBox "# of items = " & NumofItems
End Sub
This is the code I have tried initially, because before they have already separated by categories. So all that required is to count the total e-mails either by subject or number of attachments.
My issue right now is that I do not know how to target this e-mail account by using a full path.
If I know how to target that folder I think I can solve the rest of the problem myself.
After following the "possible-duplicate" link I was able to complete my code. I apologize because I did not know it was called a reference. Here is my complete solution to the issue:
Sub Test()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim Target_Folder As Outlook.MAPIFolder
Dim oItem As Object
Dim iAttachments As Integer
Set objNS = GetNamespace("MAPI")
Set objFolder_root = objNS.Folders("Testing") 'Getting Outlook Container
Set objFolder = objFolder_root.Folders("Inbox") 'Target Inbox of the other container
For Loops = objFolder.Items.Count To 1 Step -1
Set oItem = objFolder.Items(Loops)
If Category1(oItem.Subject) Then
'MsgBox "Clap1"
Set Target_Folder = objFolder_root.Folders("Category 1")
oItem.Move Target_Folder
ElseIf Category2(oItem.Subject) Then
'MsgBox "Clap2"
Set Target_Folder = objFolder_root.Folders("Category 2")
oItem.Move Target_Folder
ElseIf Category3(oItem.Subject) Then
'MsgBox "Clap3"
Set Target_Folder = objFolder_root.Folders("Category 3")
oItem.Move Target_Folder
ElseIf Category4(oItem.Subject) Then
'MsgBox "Clap4"
Set Target_Folder = objFolder_root.Folders("Category 4")
oItem.Move Target_Folder
Else
MsgBox oItem.Subject & " does not belong to any of the 4 categories"
End If
Next
End Sub
Function Category1(value)
Category_1_Keywords = Array("a")
For i = 0 To UBound(Category_1_Keywords)
If InStr(LCase(value), Category_1_Keywords(i)) > 0 Then
Category1 = True
Exit Function
Else
Category1 = False
End If
Next
End Function
There are, of course, more functions, I just posted the Category1 as a reference
Related
I want when Outlook opens to:
Search sent items with today's date with a specific subject.
If none is found, then send the "Test" email.
If found, display messagebox that says "Email is found".
I have only been able to do #1.
Private Sub Application_Startup()
Dim MItem As MailItem
Set MItem = Application.CreateItem(olMailItem)
MItem.Subject = "Test Alert"
MItem.To = "email#abc.com"
MItem.DeferredDeliveryTime = DateAdd("n", 1, Now) 'n = minute, h=hour
MItem.Send
End Sub
Update:
This is what I've tried. It doesn't seem to be searching the Sent Items folder with the subject.
Public Function is_email_sent()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olFldr As Outlook.Folder
Dim olItms As Outlook.Items
Dim objItem As Outlook.MailItem
On Error Resume Next
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(Outlook.olFolderSentMail)
For Each objItem In olFldr.Items
If objItem.Subject = "Test Alert" And _
objItem.SentOn = Date Then _
MsgBox "Yes. Email found"
Else
MsgBox "No. Email not found"
Exit For
End If
Next objItem
End Function
The main error is misuse of On Error Resume Next. Errors are bypassed, not fixed.
Public Sub is_email_sentFIX()
Dim olFldr As Folder
Dim olItms As Items
Dim objItem As Object
Dim bFound As Boolean
' Not useful here.
' Use for specific purpose to bypass **expected** errors.
'On Error Resume Next
Set olFldr = Session.GetDefaultFolder(olFolderSentMail)
Set olItms = olFldr.Items
olItms.sort "[SentOn]", True
For Each objItem In olItms
If objItem.Class = OlMail Then
Debug.Print objItem.Subject
If objItem.Subject = "Test Alert" Then
Debug.Print objItem.SentOn
Debug.Print Date
If objItem.SentOn > Date Then
MsgBox "Yes. Email found"
bFound = True
Exit For
End If
End If
End If
Next objItem
If bFound = False Then
MsgBox "No. Email not found"
End If
End Sub
If there are an excessive number of items in the Sent folder the "not found" outcome will be slow.
One possible option to the brute force way is to Restrict to the specific item, rather than using If statements.
this is some code ive used;
Sub sendmail10101() 'this is to send the email from contents in a cell
Dim obApp As Object
Dim NewMail As MailItem
Set obApp = Outlook.Application
Set NewMail = obApp.CreateItem(olMailItem)
'You can change the concrete info as per your needs
With NewMail
.Subject = Cells(21, 3).Value
.To = Cells(18, 3).Value
.Body = "Good day" & vbCrLf & "i hope you are keeping well " & vbCrLf & vbCrLf & "please can you assist with the below members infomation;" & vbCrLf & vbCrLf & vbCrLf & Cells(20, 3).Value
'.Attachments.Add ("C:\Attachments\Test File.docx")
.Importance = olImportanceHigh
.Display
End With
Set obApp = Nothing
Set NewMail = Nothing
End Sub
the next part is to search the mail box, which you can also use to search from the first initial cell;
Option Explicit
Public Sub Search_Outlook_Emails()
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outStartFolder As Outlook.MAPIFolder
Dim foundEmail As Outlook.MailItem
Set outApp = New Outlook.Application
Set outNs = outApp.GetNamespace("MAPI")
'Start at Inbox's parent folder
Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent
'Or start at folder selected by user
'Set outStartFolder = outNs.PickFolder
If Not outStartFolder Is Nothing Then
Set foundEmail = Find_Email_In_Folder(outStartFolder, ThisWorkbook.Sheets("Dashboard").TextBox1.Value)
If Not foundEmail Is Nothing Then
If MsgBox("Email subject: " & foundEmail.Subject & vbNewLine & vbNewLine & _
"Folder: " & foundEmail.Parent.FolderPath & vbNewLine & vbNewLine & _
"Open the email?", vbYesNo, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' found") = vbYes Then
foundEmail.Display
End If
Else
MsgBox "", vbOKOnly, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' not found"
End If
End If
End Sub
Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem
Dim outItem As Object
Dim outMail As Outlook.MailItem
Dim outSubFolder As Outlook.MAPIFolder
Dim i As Long
Debug.Print outFolder.FolderPath
Set Find_Email_In_Folder = Nothing
'Search emails in this folder
i = 1
While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing
Set outItem = outFolder.Items(i)
If outItem.Class = Outlook.OlObjectClass.olMail Then
'Does the findText occur in this email's body text?
Set outMail = outItem
If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail
End If
i = i + 1
Wend
DoEvents
'If not found, search emails in subfolders
i = 1
While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing
Set outSubFolder = outFolder.Folders(i)
'Only check mail item folders
If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)
i = i + 1
Wend
End Function
the previous code brings us a message box to say if its been found which can be removed but maybe use the message box and an IF statement
such as;
with activeworkbook
if msgbox.value = "yes" then
range("A1:A30") = "COMPLETED" 'ASSUMING THIS IS THE INTIAL TEST RANGE IT WILL CHANGE THE SUBJECT THUS STOPPING THE FIRST MACRO
end if
end with
or if no message box then use something such as IF found then so on...
hope this helps
EDITED
I wrote macro that finds an e-mail in shared mailbox and then replies to it. The problem is that for some cases I would like to remove my address (shared#mailbox) or some other and I don't know how to do it. I tried some methods that I found but none worked. Sorry for such a basic question.
Const olFolderInbox = 6
Sub Reminder()
On Error Resume Next
Dim olMail As Outlook.MailItem
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Set Outl = CreateObject("Outlook.Application")
Set myNamespace = Outl.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("shared#inbox")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("Inbox").Folders("AAA").Folders("BBB")
Set colItems = objFolder.Items
Dim i As Long
Dim Folder As Outlook.Folder
i = 1
For Each olMail In objFolder.Items
If olMail.Subject = "AAA" + ActiveSheet.Range("D" & (ActiveCell.Row)) Then
Set oReplyAll = olMail.ReplyAll
oReplyAll.HTMLBody = "<BODY style=font-size:10pt; font-family:Arial>Dear ,<br /> <br />" _
& "Could you please remind the client to do something?<br />" _
& "Thank you in advance.<br />" _
<br /> </BODY>" _
& oReplyAll.HTMLBody
oReplyAll.CC = "xyz#xyz"
'////////////////////////////////////////////////////////////////
'EDIT
'////////////////////////////////////////////////////////////////
For j = 1 To oReplyAll.Recipients.Count
With oReplyAll.Recipients(j)
If .Name = "aaa#bbb" Then
.Delete
j = j - 1
End If
End With
Next j
oReplyAll.Display
i = i + 1
End If
Next olMail
End Sub
Edit: I've added loop iSpain17 wrote3 in a comment. Nothing changed. Reply displays normally with recipient in "To:" part although he should be removed
There is a high probability that the text you want to match is not what you think it is.
Remove On Error Resume Next so you can fix any errors in this untested code.
With this structure you can delete/move more than one match as the index is not corrupted.
For j = oReplyAll.Recipients.Count to 1 step -1
With oReplyAll.Recipients(j)
debug.print "text to match " & .name
If .Name = "text to match" Then
.Delete
End If
End With
Next j
With this structure you can delete/move one match reliably.
For j = 1 To oReplyAll.Recipients.Count
With oReplyAll.Recipients(j)
debug.print "text to match " & .name
If .Name = "text to match" Then
.Delete
' exit now,
' else next item is skipped,
' as it moves up into the position of the deleted item
exit for
End If
End With
Next j
EDITED: Please note, that when you use the Recipients.Add method, you set the Name property of your item. Thus, when you use for loop, you'll have to test against the Name property. Also, deleting an item modifies all other item's index, thus the i=i-1. I tried this, it worked for me.
For i = 1 To email.Recipients.Count
With email.Recipients(i)
If .Name = "address" Then
.Delete
i = i - 1
End If
End With
Next i
This loops through each recipient in the recipients, and if they match the given emailmaddress they are removed from the recipients.
This might not be the exact answer as i am not too familiar with outlook vba, but this is the logic i would use.
I have a search for items, in subfolders of the Inbox, based on subject line.
I am trying to return the most recent mail and have been using the code:
Items.Sort "[ReceivedTime]", True
I also tried CreationTime and SentOn in between the brackets.
The search returns mails with the same subject line in the following order:
9/23/2016 9:31 AM
10/19/2016 12:57 PM
9/29/2016 10:54 AM
My code:
Dim Fldr As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim olMail As Variant
Set oOLapp = CreateObject("Outlook.application")
Set olNs = oOLapp.GetNamespace("MAPI")
For step = 1 To MaxCount
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
For Each Fldr in Fldr.Folders
Set Items = Fldr.Items
Items.Sort "[ReceivedTime]", True
For Each olMail in Items
If InStr(olMail.Subject, "Text" & Cstr(step))
olMail.Display Then
Set Msg = oOLapp.CreateItem(olMailItem)
.Attachments.Add olMail, olEmbeddeditem
Set Msg = Nothing
End If
Next
Next
Next
I want the one newest instance of the mail.
I also tried the code below where people seem to have the most success when trying to retrieve the most recent code.
I get
Error404 "Array index out of bounds"
For step = 1 To MaxCount
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
For i = Fldr.Folders.Count To 1 Step -1
Set Fldr = Fldr.Folders(i)
For a = Fldr.Items.Count To 1 Step - 1
Set olMail = Fldr.Items(a)
//Search and attachment code. See previous code
Next
Next
Next
RESULT:
My code pulls the mail in sequential order based on the folders it looks in. So the mail with the earliest time stamps went into a folder that appeared before the other mail so that is why my code kept pulling the earliest one instead of the latest one.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub AdvSearchForStr()
Dim strSearch As String
Dim rsts As Results
Dim i As Long
Dim rstObj As Object
Dim myMsg As MailItem
strSearch = "Test"
Dim strFilter As String
strFilter = "urn:schemas:httpmail:subject LIKE '%" & strSearch & "%'"
Debug.Print strFilter
Dim strScope As String
'strScope = "'Inbox', 'Sent Items', 'Tasks'"
strScope = "'Inbox'"
Dim objSearch As Search
Set objSearch = Application.AdvancedSearch(Scope:=strScope, Filter:=strFilter, SearchSubFolders:=True, Tag:="SearchFolder")
'Save the search results to a searchfolder
'objSearch.Save (strSearch)
' Delay to allow search to complete
' The Application.AdvancedSearchComplete event appears to be broken
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
Dim waitTime As Long
Dim delay As Date
waitTime = 1 ' in seconds - adjust as needed
Debug.Print vbCr & "Wait start: " & Now
delay = DateAdd("s", waitTime, Now)
Debug.Print "Wait until: " & delay
Do Until Now > delay
DoEvents
Loop
Set rsts = objSearch.Results
Debug.Print " rsts.Count: " & rsts.Count
If rsts.Count > 0 Then
rsts.Sort "[ReceivedTime]", True
Set rstObj = rsts(1)
rstObj.Display
Set myMsg = CreateItem(olMailItem)
myMsg.Attachments.Add rstObj, olEmbeddeditem
myMsg.Display
Else
Debug.Print "no mail found."
End If
End Sub
I had no problem running the following script in - all the messages are in the expected order - from older to newest. Did you mean to sort newest to oldest?
set folder = Application.ActiveExplorer.CurrentFolder
set items = folder.Items
items.Sort "[ReceivedTime]", False
For Each msg in items
Debug.Print msg.ReceivedTime & " " & msg.Subject
next
I am writing some VBA for Outlook, which is not something I often do. I have a strange problem with the following code:
Sub Archive()
Dim objSourceFolder As Folder
Dim OldMessages As Outlook.Items
Dim Allmessages As Outlook.Items
Dim objMessage As MailItem
Dim dtDate As Date
Dim strDate As String
Dim strProblemFiles As String
Dim objTargetFolder As Outlook.MAPIFolder
'how old is too old? give a number in months
'-----------------------------------------------
Const iMonthAge = 6
'-----------------------------------------------
strProblemFiles = ""
'locate the sourcefolder as the inbox
Set objSourceFolder = Application.Session.GetDefaultFolder(olFolderInbox)
'locate the target folder as the only one that can work according to IT - they will make this folder consistent apparently
Set objTargetFolder = Application.Session.Folders.GetFirst
Set objTargetFolder = objTargetFolder.Folders("Archive")
'There is this crappy thing on the filtering of messages where it takes a date string, not a date. So we need to calculate and then convert
'to the format that MS lists on the MSDN site
dtDate = DateAdd("M", -iMonthAge, Now())
strDate = Format(dtDate, "ddddd h:nn AMPM")
'apply a filter to only show messages older than the specified date, which have been read.
Set Allmessages = objSourceFolder.Items
Set OldMessages = Allmessages.Restrict("[Received] <= '" & strDate & "' AND [Unread] = False")
'let the poor user know what's going on - they can bail out now if they want
If MsgBox("There are " & OldMessages.Count & " old items to archive. They will be moved from your " & objSourceFolder.Name & _
" folder to your " & objTargetFolder.Name & " folder.", vbYesNo, "Archive Files Now?") = vbYes Then
'go through all the messages in the big list of messages older than the specified date, moving them if possible.
For Each objMessage In OldMessages
If TypeName(OldMessages.GetFirst) = "MailItem" Then
'do our shizzle
Else
'PRETTY MINIMAL ERROR CATCHING NEEDS IMPROVING
'write down the name of anything that isn't mail, I guess... need to work on this
strProblemFiles = strProblemFiles + vbCrLf + objMessage.Subject
GoTo errorcatch
'GoTo CarryOn
End If
'make a note for anyone who can look
Debug.Print objMessage.Subject
If objTargetFolder.DefaultItemType = olMailItem Then
If objMessage.Class = olMail Then
'There's nothing in errorcatch, but there will be
On Error GoTo errorcatch
'Move the item if you can
objMessage.Move objTargetFolder
End If
End If
'after an error, we jump here to go to the noxt item
CarryOn:
Next
Else
'if the user doesn't want to do it, we need to shut up shop and get the hell out of here
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
Exit Sub
End If
'now we have done the whole thing, we can wipe down for fingerprints and exit through the window
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
'reset the errors
On Error GoTo 0
'probably not going to be any that weren't mail items, but didn't cause a real error, but I guess we should show any we skipped.
If strProblemFiles <> "" Then MsgBox strProblemFiles
Exit Sub
'pathetic
errorcatch:
GoTo CarryOn
End Sub
Function FileExists(FileName As String) As Boolean
FileExists = (Dir(FileName) <> "")
End Function
Everything works... nearly. the first time I run the macro, it tells me that there are (e.g. 128 items ready to archive. It runs and I notice that there are still old messages in my inbox, so I run it again and it tells me there are 64 items ready for archive... then 32, 16 etc. halving the number of found messages each time. I cannot see why it would do this. Any ideas?
I should mention that this is running on Outlook 2010, using an Exchange.
Thanks for looking - all answers most appreciated!
Cheers,
Mark
Something like:
'...
Dim colMove As New Collection
'...
For Each objMessage In OldMessages
If objTargetFolder.DefaultItemType = olMailItem Then
If objMessage.Class = olMail Then colMove.Add objMessage
End If
Next
For Each objMessage In colMove
objMessage.Move objTargetFolder
Next
'...
The For Each issue is explained, and another method to move or delete items counting backwards is described here.
For Each loop: Just deletes the very first attachment
Option Explicit
Sub Archive()
Dim objSourceFolder As Folder
Dim OldMessages As Outlook.Items
Dim AllMessages As Outlook.Items
Dim objMessage As Object
Dim dtDate As Date
Dim strDate As String
Dim strProblemFiles As String
Dim objTargetFolder As Outlook.MAPIFolder
Dim colMove As New Collection
Dim objFolder As Outlook.MAPIFolder
Dim lngSize As Long
Dim objAnything As Object
Dim iMaxMBSize As Integer
Dim boolSentItems As Boolean
Dim catCategory As category
' Dim boolCatExists As Boolean
' Dim iColour As Integer
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
'iColour = 18
'we are moving files, that's all, so we don't really need to worry too much about errors - if there is a problem, we can just skip the file
'without great negative effects.
On Error Resume Next
'how old is too old? give a number in months
'-----------------------------------------------
Const iMonthAge = 6
iMaxMBSize = 50
'-----------------------------------------------
'locate the sourcefolder as the inbox
boolSentItems = (MsgBox("Your inbox will be archived." & vbCrLf & _
"Do you want to also archive sent items?", vbYesNo, "Archive Options") = vbYes)
Set objSourceFolder = Application.Session.GetDefaultFolder(olFolderInbox)
'----------------------------------------------------------------------------------------------------------------------------------------
StartAgain:
'If you wish to assign a category to the folders rather than keep the folder structure when you archive, use this code and some other bits
'later on, which mention the categories and the variables mentioned here.
'Set objSourceFolder = Application.Session.GetDefaultFolder(olFolderInbox)
' boolCatExists = False
'For Each catCategory In Application.Session.Categories
' If catCategory.Name = "Archived from " & objSourceFolder.Name Then
' boolCatExists = True
' End If
'Next
'If boolCatExists = False Then
' Application.Session.Categories.Add "Archived from " & objSourceFolder.Name, iColour
'End If
'locate the target folder, which must be either in the same level as the inbox or lower
'----------------------------------------------------------------------------------------------------------------------------------------
Set objTargetFolder = SearchFolders(objSourceFolder.Parent, "Archive")
'if the target folder was not found, then we need to make it, in the root directory (the same level as the inbox - this is stipulated by IT)
If objTargetFolder Is Nothing Then
Set objTargetFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add("Archive")
End If
'we are going to maintain the folder structure in the archive folder, for the inbox and sent items. This means we know exactly what to look for. If it isn't there,
'we just create it. I have used the search, rather than specifying the folders so that if the archiving is extended to more than just the inbobx and sent items, no
'change is needed.
If SearchFolders(objTargetFolder, objSourceFolder.Name) Is Nothing Then
Set objTargetFolder = objTargetFolder.Folders.Add(objSourceFolder.Name)
Else
Set objTargetFolder = objTargetFolder.Folders(objSourceFolder.Name)
End If
'There is this crappy thing on the filtering of messages where it takes a date string, not a date. So we need to calculate and then convert
'to the format that MS lists on the MSDN site
dtDate = DateAdd("M", -iMonthAge, Now())
strDate = Format(dtDate, "ddddd h:nn AMPM")
'apply a filter to only show messages older than the specified date, which have been read.
Set OldMessages = objSourceFolder.Items
Set OldMessages = OldMessages.Restrict("[Received] <= '" & strDate & "' AND [Unread] = False")
'let the poor user know what's going on - they can bail out now if they want
If OldMessages.Count > 0 Then
' If MsgBox("There are " & OldMessages.Count & " old items in your " & objSourceFolder.Name & ". Do you want to move them from your " & objSourceFolder.Name & _
' " folder to your " & objTargetFolder.Name & " folder.", vbYesNo, UCase(objSourceFolder.Name) + " Archive") = vbYes Then
'----------------------------------------------------------------------------------------------------------------------------------------
'go through all the messages in the big list of messages older than the specified date, moving them if possible.
'StatusForm.Show vbModeless
For Each objMessage In OldMessages
If TypeName(objMessage) = "MailItem" Then
'do our shizzle
Else
'if it is not a mailitem, there may be problems moving it - add it to the list instead.
strProblemFiles = strProblemFiles + vbCrLf + objSourceFolder.Name + ": " + objMessage.Subject
End If
'make a note for anyone who can look
Debug.Print objMessage.Subject
'probably pointless since we are only looking in the inbox and sent items, and making the mirrors ourselves, but check the folder is correct
If objTargetFolder.DefaultItemType = olMailItem Then
If objMessage.Class = olMail Then
'put the message in a nice stable collection for now - that way, we don't have to worry about the count changing etc
colMove.Add objMessage
End If
End If
Next objMessage
'----------------------------------------------------------------------------------------------------------------------------------------
'and here we have the actual move (and some optional text if you are using the categories)
For Each objMessage In colMove
'Move the item if you can
'objMessage.Categories = "Archived from " & objSourceFolder.Name
'objMessage.Save
objMessage.Move objTargetFolder
Next objMessage
'----------------------------------------------------------------------------------------------------------------------------------------
'Else
' 'if the user doesn't want to do it, we need to shut up shop and get the hell out of here
' Set objSourceFolder = Nothing
' Set OldMessages = Nothing
' Set objMessage = Nothing
' Set objTargetFolder = Nothing
' Exit Sub
'End If
Else
'if the count of all the old messages is not greater than 0
MsgBox "There are no messages from more than " & iMonthAge & " months ago in your " & objTargetFolder.Name & _
", so nothing will be archived.", vbExclamation, "Mailbox is Clean"
End If
'----------------------------------------------------------------------------------------------------------------------------------------
'finally, loop through literally all the items in the target folders and add up the sizes to see how much we have archived in total.
For Each objAnything In objTargetFolder.Parent.Items
lngSize = lngSize + objAnything.size
Next
'if they want to include the sent items in the archive, then change over the folder and do it all again
If boolSentItems = True Then
boolSentItems = False
Set objSourceFolder = SearchFolders(objSourceFolder.Parent, "Sent Items")
'iColour = iColour + 1
GoTo StartAgain
End If
'----------------------------------------------------------------------------------------------------------------------------------------
'once we have done all we can, let the user know about all the files that were skipped.
If strProblemFiles <> "" Then
MsgBox "The following items were skipped, so will still be in your mailbox" & vbCrLf & strProblemFiles, vbOKOnly, "Non-Mail Items"
Else
MsgBox "Archive complete", vbOKOnly, "Files Moved"
End If
'----------------------------------------------------------------------------------------------------------------------------------------
'the size of each file is listed in Bytes, so convert to MB to check the MB size and display, for convenience.
If lngSize / (1024 ^ 2) >= iMaxMBSize Then
MsgBox "Your archive folder takes up " & Round(lngSize / (1024 ^ 2), 0) & "MB; it is time to call IT to ask them to clear out the files", vbOKOnly, _
"Archive folder bigger than " & iMaxMBSize & "MB"
End If
'now we have done the whole thing, we can wipe down for fingerprints and exit through the window
Set objSourceFolder = Nothing
Set OldMessages = Nothing
Set objMessage = Nothing
Set objTargetFolder = Nothing
StatusForm.Hide
On Error GoTo 0
Exit Sub
'ErrorCatch:
'If you decide to add some error checking, put it in here, although as I say, I haven't bothered (see Declaration section at top)
End Sub
Public Function SearchFolders(objTopFolder As Outlook.MAPIFolder, strName As String)
Dim objFolder As Outlook.MAPIFolder
'look through all the sub folders at the level we started
For Each objFolder In objTopFolder.Folders
'If we find the one that we are looking for, great! we can get it and get out
If objFolder.Name = strName Then
Set SearchFolders = objFolder
Exit Function
'if we haven't found our magic folder yet, we need to carry on, by looking for any sub-sub folders this is done by calling the function itself on
'the current folder (which is by definition already one level lower than the starting location). if nothing is found, we,ll just carry on
Else
If objFolder.Folders.Count > 0 Then
Call SearchFolders(objFolder, strName)
End If
End If
Next
'the only way to exit the loop at this point is if all the folders have been searched and the folder we were looking for was not found.
Set SearchFolders = Nothing
End Function
the "StatusForm" user form that is referred to is a completely static form that just says "Archiving..." so the user is less likely to try mucking around in Outlook while the macro runs.
I have put together a vba script (that runs in ThisOutlookSession) that monitors MailItems added to my sent folder, and when it detects a project number in the subject, it copies that MailItem to a shared mailbox location automatically based on that project number.
The scripts works well, however I would like to categorize all MailItems copied/moved by the script, so that users will have a visual indication to which messages were automatically moved by the script (since the end product will run invisible in the background).
I'm missing something somewhere as its not assigning the category at the end of my script. Below is my full script (including my attempt to assign the mailitem to a category, which is under the " 'Assigns Category to Mailitem " comment). Any help, insight or direction will be immensely appreciated:
Private WithEvents Items As Outlook.Items
Private CancelLoop As Boolean
Private DupSubject As String
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Set InboxItems = GetNS(olApp).GetDefaultFolder(olFolderInbox).Items
Set Items = GetNS(olApp).GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
'Start Loop Check - Compares to last moved mailitem
If item.Subject = DupSubject Then
CancelLoop = True
End If
If (CancelLoop) Then
MsgBox ("Ending Script (Loop Detected)")
CancelLoop = False
Exit Sub
End If
On Error Resume Next
MsgBox "New item in the SENT Folder, Checking for T-#"
Dim EmailSub As String
Dim EmailSubArr As Variant
Dim ProjectNum As String
Dim FullProjectNum As String
Dim ProjNumLen As Long
Dim ParentFolderName As String
Dim SubFolderName As String
If TypeName(item) = "MailItem" Then
'Checks Email Subject for Project Number Tag
If InStr(item.Subject, "T-") > 0 Then
MsgBox "T-# Detected"
'Splits out Project Number into an Array for Extraction
EmailSub = item.Subject
EmailSubArr = Split(EmailSub, Chr(32))
For i = LBound(EmailSubArr) To UBound(EmailSubArr)
If InStr(EmailSubArr(i), "T-") > 0 Then
FullProjectNum = EmailSubArr(i)
MsgBox "T-# Extracted"
ProjNumLen = Len(FullProjectNum)
MsgBox ("T-# is " & ProjNumLen & " Characters Long")
'Project Number Length Check and Formatting
If ProjNumLen >= 11 Then
Exit Sub
End If
If ProjNumLen <= 6 Then
Exit Sub
End If
If ProjNumLen = 10 Then
'Really Extended T-# Format 1(ie T-38322X12)
ProjectNum = Right(FullProjectNum, 8)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 8)
End If
If ProjNumLen = 9 Then
'Extended T-# Format 1(ie T-38322X1)
ProjectNum = Right(FullProjectNum, 7)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 7)
End If
If ProjNumLen = 8 Then
'Uncommon T-# Format (ie T-38322A)
ProjectNum = Right(FullProjectNum, 6)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 6)
End If
If ProjNumLen = 7 Then
'Standard T-# Format (ie T-38322)
ProjectNum = Right(FullProjectNum, 5)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 5)
End If
Exit For
End If
Next i
MsgBox ("Confirm Extraction (1 of 3) - Project Number is T-" & ProjectNum)
MsgBox ("Confirm Extraction (2 of 3) - Parent Folder Will Be " & ParentFolderName)
MsgBox ("Confirm Extraction (3 of 3) - Sub Folder Will Be " & SubFolderName)
MsgBox ("Will Now Perform Folder Checks")
'Perform Folder Checks, Creates Folders When Needed
Dim fldrparent As Outlook.MAPIFolder
Dim fldrsub As Outlook.MAPIFolder
Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName)
Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
If fldrparent Is Nothing Then
MsgBox "Parent Folder Does Not Exist, Creating Folder"
Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders.Add(ParentFolderName)
Else
MsgBox "Parent Folder Already Exists, Do Nothing"
End If
If fldrsub Is Nothing Then
MsgBox "Sub Folder Does Not Exist, Creating Folder"
Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders.Add(SubFolderName)
Else
MsgBox "Sub Folder Already Exists, Do Nothing"
End If
'Moves Copy of Email to Folder
MsgBox "Copying Sent Email to Project Folder"
Dim myCopiedItem As Outlook.MailItem
Dim FolderDest As Outlook.MAPIFolder
Set myCopiedItem = item.Copy
Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
item.Move FolderDest
MsgBox "Copy Complete"
'Assigns Category to Mailitem
item.Categories = "Copied2Projects"
item.save
'Duplicate Email/Loop Check
DupSubject = EmailSub
Set objExplorer = Nothing
Else
MsgBox "Did not detect T-##### project number"
End If
End If
End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
Your problem is here:
Dim myCopiedItem As Outlook.MailItem
item.Move FolderDest
MsgBox "Copy Complete"
'Assigns Category to Mailitem
item.Categories = "Copied2Projects"
item.save
Outlook does weird things when you move an item, effectively creating a new item you no longer have access to if you don't do something to track it. There are a few ways to fix this problem.
You can just move the code saving prior to the .Move command and avoid this problem entirely.
Otherwise, you can try something like
Set myCopiedItem = item.Move(FolderDest)
myCopiedItem.Categories = "Copied2Projects"
myCopiedItem.save
which should also work.
This drove me NUTS for a long time with a related problem once upon a time...