Track email through the draft/send/sent process - vba

I'd like to follow the status of an email as it passes through the phases and folders of its life cycle, through "Drafts", "Outbox", and "Sent".
Of related interest is the ability to access existing emails to gather property info, such as sent time.
I've started with the included block of code. The Do Loop fails the moment the email is sent, because the variable disconnects from the email.
This causes the runtime error
The item has been moved or deleted.
The error number (Err.Number) is different every time, and I wonder what the design purpose is.
How can I stay connected to sending emails as they move through Drafts, Outbox, and Sent?
I see many mentions of the variable disconnecting from the mailitem, but no solutions that rely on the object hierarchy and avoid late-binding to address the issue. I thought perhaps there would be a GUID or UUID that identifies the message, but as indicated in the documentation, all properties such as EntryID can change if the item is moved, and such properties should not be relied on.
With deeper examination, this makes sense because an email is just a record in a database table. And if you duplicate/delete records between tables, the info might be the same or similar, but the record number probably won't be.
Also, that hits other nails: the same email can be sent multiple times, and also can be copied/pasted into different folders, and even different accounts. Now what's unique or not?
Aside from staying "connected" to a email, what properties or techniques can be used to ID one?
If there's no "proper" way to identify a mailitem as described, about the only thing I can think of is to use an existing or custom field, like the "Tag" property of OCX controls, to insert a UUID. Some companies use this sort of technique by putting a call/order/support number in the subject line to make then easier to track.
Dim outlobj As Outlook.Application
Dim mailobj As Outlook.MailItem
Set outlobj = Outlook.Application
Set mailobj = outlobj.CreateItem(olMailItem)
With mailobj
.Recipients.Add "wonderwoman#hallofjustice.com"
.Subject = "Invisible Jet Scheduled Maintenance Reminder"
.Body = "Your invisible jet need to be polished."
.Attachments.Add zipFilename
.Display
.Send
End With
Do
'next line fails due to email moving through Drafts, Outbox, & Sent
'notably, the VBA runtime Err.Num is different each time
'how do i keep the variable connected to a moving target?
If mailobj.Sent = False Then
Sleep 100
Else
MsgBox "The email has been sent."
'other code
Exit Do
End If
Loop

Create a class and add MailItem as the event enabled property of that class. Handle the events such as Open/Write/Send/Save etc. to have custom control on the e-mail life-cycle. EntryID is the unique property for each mail item.
Be cautious of the fact that Entry Id is only generated after the first save of the item and changes implicitly when user manually moves the item between folders.
Following a is an example to get you started:
Add a class Class1 like this
Option Explicit
Public WithEvents mItem As MailItem
Public id As String
Private Sub mItem_Open(Cancel As Boolean)
MsgBox "Mail item will be displayed."
id = mItem.EntryID
End Sub
Add a module with following code:
Option Explicit
Sub test()
Dim cls As New Class1
Dim id As String
Dim outlobj As Outlook.Application
Dim mailobj As Outlook.MailItem
Set outlobj = Outlook.Application
Set mailobj = outlobj.CreateItem(olMailItem)
Set cls.mItem = mailobj
With mailobj
.Recipients.Add "xx#yy.zz"
.Subject = "Test"
.Body = "Test Content of the e-mail."
.Save
.Display
id = cls.id '/ Store ID for later use.
Debug.Print id
End With
'/ Search that e-mail and display its body contents
Call Retrieve(id)
End Sub
Sub Retrieve(sEntryId As String)
Dim mailobj As Outlook.MailItem
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Set mailobj = ns.GetItemFromID(sEntryId)
MsgBox mailobj.Body
End Sub
Run the sub test

Related

Outlook Rules - Alternative to wildcards

Every day I get one or more spam emails of a very specific type to my xxxxx#gmail account.
They all have a garbled and unique FROM: email address.
The TO: and CC: fields are always of the form xxxxx[random chars]#aol.com. For example I got one today with
TO: xxxxx#aol.com
CC: xxxxxY7#aol.com
I would like to create a rule to automatically send these to spam and block. Two possible conditionals would be:
"with xxxxx AND #aol.com in recipient's address"
"with xxxxx*#aol.com in recipient's address" (with * as a wildcard).
#1 doesnt work because the "specific words" it requests are concatenated with OR, no option to use AND.
#2 doesn't work because as far as I can tell there is no way to use wildcards.
Any suggestions? I realize there probably is a straightforward VBA script solution but I haven't played with VBA in over a decade. Was hoping there might be another clever non-VBA work around. Thanks.
There is no workaround. You can handle incoming emails in Outlook VBA by handling the NewMailEx event of the Application class. This event fires once for every received item that is processed by Microsoft Outlook. The item can be one of several different item types, for example, MailItem, MeetingItem, or SharingItem. The EntryIDsCollection string contains the Entry ID that corresponds to that item. You can use the Entry ID from the EntryIDCollection parameter to call the NameSpace.GetItemFromID method and process the item.
In the NewMailEx event handler you can check the required properties such as Recipients and etc. and move the item wherever you need.
As stated, NewMailEx can be used to handle some filtering like this and I have a regex filter that I use as standard automatic rules don't allow that (or at least not currently - maybe a future upgrade). If you can use a regex to identify the e-mails you want to process then you could use this code:
In ThisOutlookSession
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Call RegExFilterRules(EntryIDCollection)
End Sub
In a module
Sub RegExFilterRules(ItemID As String)
With Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = .GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = .GetDefaultFolder(olFolderJunk)
Dim olItem As Outlook.MailItem: Set olItem = .GetItemFromID(ItemID, Inbox.StoreID)
End With
'On Error Resume Next
If Not olItem Is Nothing And olItem.Class = olMail Then
If IsPatternFound(olItem.subject, "^M\d+$") Then olItem.Move Junk 'olItem.Delete 'olItem.UnRead = False
If olItem.Sender = "cortana#microsoft.com" Then olItem.Delete
End If
Set olItem = Nothing
End Sub
Private Function IsPatternFound(Content As String, Pattern As String) As Boolean
' Requires Reference: Microsoft Scripting Runtime
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.RegExp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = Pattern
IsPatternFound = .Test(Content)
End With
End Function

How to search recipients of previously sent mail?

I have a code which checks the subject in my e-mail and warns me if I already sent an email with this subject. I experienced it would be smarter if it checks for the email address.
I tried substituting "subject" with "recipients" but without success.
Public Sub Application_ItemSend(ByVal thisItem As Object, Cancel As Boolean)
Dim ns As Outlook.NameSpace
Dim olfolder As MAPIFolder
Dim Item As Object
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set firstFolder = olNs.Folders("test#dk.com") ' name of my shared inbox
Set olfolder = firstFolder.Folders("sent items")
' iterate thru emails
For Each Item In olfolder.Items
' check subject content & date difference
If InStr(Item.Subject, thisItem.Recipients) And DateDiff("m", Item.SentOn, Now) < 1 Then
' added this part
If MsgBox("already sent", vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Message Text Warning") = vbNo Then
' cancel the email
Cancel = True
End If
Exit For
End If
Just replace thisItem.Subject to thisItem.To
edit: Nathan_Sav said it all :) .Recipents property returns an array so you can loop through it, might as well use .To which will return all recipients separated by semicolon
edit2: note there are two other properties .cc and .bcc if you use them, whilst .Recipients array include all of them
Firstly, do not ever loop through all items in a folder - this is horribly inefficient. Use Items.Find with a restriction on the Subject and SentOn properties.
For the recipients, you can use a restriction on the To property, but keep in mind that on the MAPI level it translates to a restriction on the PR_DISPLAY_TO property, which may or may not include the actual email address. OOM does not create subrestrictions on the PR_MESSAGE_RECIPIENTS property. If using Redemption (I am its author) is an option, its version of RDOItems.Find/Restrict allows to specify Recipients, To, CC, BCC properties in a query and creates an appropriate restriction on the email address and name of the message recipients.
In the worst case you can restrict on the Subject and SentOn properties using Items.Find/FindNext or Items.Restrict, and then explicitly loop through the Recipients collection of the returned matches.

Save Attachments From New Email

I'm trying to use Outlook VBA to check all my emails on startup, and whenever I receive a new email, to see if the email subject is "Sample Daily Data Pull". If the email subject matches, I want outlook to save the attachment to a specified network drive folder. Here is the code I have:
In "ThisOutlookSession"
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
If Item.Subject = "Sample Daily Data Pull" Then
Call SaveAttachmentsToDisk
Else
End If
End If
End Sub
I also have the following code in a module:
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "N:\SampleFilePath\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub
This is my first time working in Outlook VBA, so my apologies if it's something very basic and obvious. Not really sure what is going wrong as I'm not getting any error messages. All I know is that the the macro is not saving attachments on my network drive as it should be.
Thanks in advance for any help.
Your code does not work for me because of:
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
Outlook saves mail items, calendar items, tasks and other such information in files it calls Stores. You can have several stores each of which will have an Inbox. I am a home user with two email accounts. I did a default installation of Outlook then used a wizard to add an account for each of my email addresses. The result is I had three stores:
Outlook Data File
MyName#myisp.com
MyName#gmail.com
“Outlook Data File” is the default store and contains the default Inbox but new emails are placed in the Inboxes in the other two stores. To test if you have the same problem, open Outlook, open the VBA Editor, type the following into your Immediate Window and press [Return].
? Session.GetDefaultFolder(olFolderInbox).Parent.Name
On my system, this statement outputs “Outlook Data File” because that store contains the default Inbox. If I want to have an event handler for new emails I need to have:
Private Sub Application_Startup()
Set InboxItems = Session.Folders("MyName#myisp.com").Folders("Inbox").Items
End Sub
This is someone shorter than your macro, which I will explain later, but the key difference is I am naming the Inbox I wish to monitor. If the Inbox that receives your new emails is not Outlook’s default Inbox, you will have to name the folder containing the Inbox you wish to monitor.
Why is my macro so much shorter than yours?
Dim outlookApp As Outlook.Application
Set outlookApp = Outlook.Application
You are already within Outlook so these statements are redundant.
You could replace:
Set objectNS = outlookApp.GetNamespace("MAPI")
by
Set objectNS = Application.GetNamespace("MAPI")
But you do not have to. The only GetNamespace is under Application so the qualification is optional. The only qualification that I know to be non-optional is Outlook.Folder and Scripting.Folder. If you write Folder within Outlook it assumes you want one of its folders. If you want to refer to a disk folder you must say so.
You have:
Dim objectNS As Outlook.NameSpace
Set objectNS = outlookApp.GetNamespace("MAPI")
I have used Session. The documentation states that Namespace and Session are identical. I prefer Session but most people seem to prefer Namespace. Your choice.
If you are references the correct Inbox, we need to look further for the cause of your problem.
The next possible issue is If Item.Subject = "Sample Daily Data Pull". This requires Item.Subject be exactly equal to "Sample Daily Data Pull". An extra space or a lower case letter and they are not equal.
Next, I suggest adding a statement at the top of each of procedure to give:
Private Sub Application_Startup()
Debug.Assert False
: : :
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
Debug.Assert False
: : :
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Debug.Assert False
: : :
Many programming languages have an Assertion statement; this is VBA’s version. It allows the programmer to assert that something will be true. Execution will stop if the assertion is false. I find Debug.Assert False invaluable during testing. Debug.Assert False will always be false so execution will always stop. This is an easy way to test that Application_Startup, inboxItems_ItemAdd and SaveAttachmentsToDisk are being executed.
Try the above suggestions. If they fail to find a problem, we will have to try something else.
Error Handling
In your original posting, you had:
On Error GoTo ErrorHandler
: : :
: : :
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
You will often see code like this but I have never seen a justification for it.
If an error occurs during development, this code will result in the error number and description being displayed and the routine exited. How is this helpful? It leaves you to guess from the error description which statement failed. If you omit all the error code, execution stops on the faulty statement. There is no guessing as to which statement was in error. If you can fix the error, you can click F5 and restart with the previously faulty statement. Even if you cannot fix and restart, you have a better understanding of the situation.
For a live system, I have difficulty in imagining anything less user friendly than an error resulting in display of a cryptic error message and the macro terminating.
For a live system, you want something like:
Dim ErrNum As Long
Dim ErrDesc As String
On Error Resume Next
Statement that might fail
ErrNum = Err.Num
ErrDesc = Err.Description
On Error GoTo 0
If ErrNum > 0 Then
' For each possible value for ErrNum, code to provide user friendly
' description of what has gone wrong and how to fix it.
End If
VBA is not the ideal language for writing code that fails gracefully but with care you can create some very acceptable error handling code.

Forward mail and add content to body (Outlook 2007, VBA)

Can anyone help me with editing the VBA-Code for the following Problem:
I want to forward e-mails with a specific subject to an specific E-Mail. In this process i want to add a text to the forwarded body.
Thank's for your help!
edit.
I have the code now, but it doesn't work properly. It sends the last E-Mail clicked on :(.
Sub Test(oMail As MailItem)
Dim MyItem As Outlook.MailItem
Dim obj_curitem As MailItem
Dim obj_newitem
Dim obj_Selection
Dim obj_curfolder
Dim obj_msgitems
Dim Forward As Object
If Err.Number = 0 Then
Set obj_Selection = Outlook.ActiveExplorer.Selection
If obj_Selection.Count > 0 Then
For Each obj_curitem In obj_Selection
strID = obj_curitem.EntryID
Set olNS = Application.GetNamespace("MAPI")
'Object auf einem neuen Item erstellen
Set obj_newitem = obj_curitem.Forward
With obj_curitem.Forward
.Forward = True
.SentOnBehalfOfName = "###" 'Deine Mailadresse
.Subject = "WG" & .Subject 'Betreff
.To = "###" 'Empfängermail
.BODY = "geprüft" & .BODY 'E-Mail Inhalt
.Send
End With
Next
End If
End If
End Sub
In general you will need to handle the NewMailEx event of the Application class where you can check out the Subject property and decide whether to forward the email or not. The Forward method of the Application class allows you doing so - it executes the Forward action for an item and returns the resulting copy as a MailItem object.
This NewMailEx event fires once for every received item that is processed by Microsoft Outlook. The item can be one of several different item types, for example, MailItem, MeetingItem, or SharingItem. The EntryIDsCollection string contains the Entry ID that corresponds to that item. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item.
The Outlook object model provides three main ways for working with item bodies:
Body.
HTMLBody.
The Word editor. The WordEditor property of the Inspector class returns an instance of the Word Document which represents the message body. So, you can use the Word object model do whatever you need with the message body.
See Chapter 17: Working with Item Bodies for more information.

Forwarding Outlook Item as attachment and adding it to a category in the same VBA macro

I have a macro that works for forwarding multiple Outlook items as attachments. I've pasted that below, but I want it to also add the forwarded message(s) to a category in outlook. So, not only would it forward the items that are in my inbox to the recipient, but it would also mark those items in a certain category. This way I could track which items I have forwarded using the macro. As it is now, it will show me the item has been forwarded on such and such date, but that may have been just a regular forwarding action. Hence the need for the macro to add the item to a specialized category.
Sub ForwardSelectedItems()
On Error Resume Next
Dim objItem As Outlook.MailItem
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No item selected")
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
Set objMsg = objItem.Forward()
With objMsg
.Attachments.Add objItem, olEmbeddeditem
.Subject = "example"
.To = "example#example.com"
.Body = “”
.Send
End With
Next
Set objItem = Nothing
Set objMsg = Nothing
End Sub
The Categories property of the MailItem class allows to set a string representing the categories assigned to the Outlook item. Here is what MSDN states:
Categories is a delimited string of category names that have been assigned to an Outlook item. This property uses the character specified in the value name, sList, under HKEY_CURRENT_USER\Control Panel\International in the Windows registry, as the delimiter for multiple categories. To convert the string of category names to an array of category names, use the Microsoft Visual Basic function Split.
Note, you can use the Categories property of the Namespace class to get a Categories object that represents the set of Category objects available. This property represents the Master Category List, which is the set of Category objects that can be applied to Outlook items contained by the NameSpace object, and applies to all users of that namespace.
Also you may consider specifying the SaveSentMessageFolder for the mail item. The property allows to set a Folder object that represents the folder in which a copy of the e-mail message will be saved after being sent. So, you can easily recognize the auto-forwarded messages.