Access/VBA Library

Saving e-mails after sending

When you send an e-mail to a customer, you might want to save the e-mail somewhere on the filesystem or in a database. This can be a very tricky. You can open an e-mail item using the Outlook.Application:

Public Function CreateNewEmail() As Outlook.MailItem

    Dim olkApp As New Outlook.Application
    Dim olkNS As Outlook.NameSpace
    Dim olkMI As Outlook.MailItem
    
    Set olkApp = New Outlook.Application
    '
    ' Open outlook en MAPI name-space
    '
    Set olkNS = olkApp.GetNamespace("MAPI")
    Set olkMI = olkApp.CreateItem(olMailItem)

    olkMI.Display
    
    Set CreateNewEmail = olkMI
End Function

This function creates a new Outlook Mailitem and opens it. The user can now enter the receiver(s), subject and the body of the mail. You can access the mailitem using the reference returned by the function CreateNewEmail.

But, when the user the presses "Send" the email is sent and the reference to the mailitem is lost. The problem is that Outlook places the sent item in another folder (e.g. Sent items) and treats the mailitem as another object. In this way the reference returned by CreateNewEmail is lost.

Identifying mailitems

To save the e-mail after sending, you have to walk through the sent items and find the corresponding mailitem. But, how to identify which mailitem just has been sent? Outlook does not provide a property containing a unique id.
For these cases I use the Categories property of a mailitem to store a unique identifier, so I can find the mailitem later on:

Dim mi As Outlook.mailItem
Dim id As String

Set mi = CreateNewEmail()
' Generate a unique E-mail id
Randomize
id = Format(Now(), "yyyymmddhhnnss") & "_" & CInt(1000 * Rnd()) + 1
' Change mail item properties
With mi
    .To = "somebody@company.com"
    .Subject = "Please contact us"
    .Body = "Dear mr/mrs. ...."
    .Categories = id
End With

Now we have the mailitem identified uniquely, but are facing another problem: how do we know when the e-mail has been sent?

Check if mailitem is open

We can use the Inspectors property of the Outlook.Application object to get all windows which are open and holding a Outlook item. The only thing we can do now is to walk through all open windows and check whether the window holding a mailitem which property Categories is the same Id as generated before:

Private Function MailItemIsOpen(itemID As String) As Boolean
    Dim olkInsp As Outlook.Inspector
    Dim X As Object
    Dim olkMI As Outlook.mailItem
    
    On Error Resume Next
    MailItemIsOpen = False
    For Each olkInsp In olkApp.Inspectors
        Set X = olkInsp.currentItem
        If Err.Number = 0 Then
            If TypeName(X) = "MailItem" Then
                ' type casting...
                Set olkMI = X
                ' check if this is the item we are looking for
                If olkMI.Categories = itemID Then
                    MailItemIsOpen = True
                    Exit For
                End If
            End If
        End If
    Next olkInsp
End Function

'
' How to use this function?
'
While MailItemIsOpen(id)
    DoEvents
Wend

Find mailitem in sent items

After the window of the mailitem has been closed we must determine whether the mailitem has been sent or not. We can perform this task very easily by browsing the Sent items folders and check the Categories of all mailitems in this folder. But we have to deal with to issues:

  • When the Outlook server is busy, it might take a while before the sent mailitem will be put into the Sent items.
  • For some user the Sent items contains a tremendous amount of mailitems, so we need some intelligence by filtering the mailitems. Unfortunately it is not possible to apply a filter on the Categories property.

There are more solutions to handle these issues, but after a while this solution works the best for me:

Private Function FindSentItem(itemID As String, sentFromTime As Date) As Outlook.mailItem
    Const MAX_TRY_COUNT = 3
    Const SLEEP_TIME = 1000
    
    Dim items As Outlook.items
    Dim item As Object
    Dim attempt As Integer
    
    attempt = 1
    
findSentItem_start:
    With olkNS.GetDefaultFolder(olFolderSentMail)
        Set items = .items.Restrict("[SentOn] >= '" & Format(sentFromTime, "ddddd h:nn AMPM") & "'")
        For Each item In items
            If TypeName(item) = "MailItem" Then
                If item.Categories = itemID Then
                    Set FindSentItem = item
                    Exit Function
                End If
            End If
        Next item
    End With
    '
    ' If not found at this attempt, try again
    ' after some sleep
    '
    If attempt < MAX_TRY_COUNT Then
        attempt = attempt + 1
        Call Sleep(SLEEP_TIME)
        GoTo findSentItem_start
    End If
    Set FindSentItem = Nothing
    
End Function

In this solution I save the date and time after creating the mailitem and only the mailitems sent after this date and time are searched by calling the Restrict method. When the mailitem not is found after the first attempt, the function tries to find the mailitem during two following attempts and after a sleep of 1 second. When the mailitem not is found after three attempts the user probably closed the window without sending the e-mail. In this case Nothing is returned by this function.

Putting it all together

So, we can now put all together:

Dim mi As Outlook.mailItem
Dim id As String
Dim sentAfter As Date

Set mi = CreateNewEmail()
' Generate a unique E-mail id
Randomize
id = Format(Now(), "yyyymmddhhnnss") & "_" & CInt(1000 * Rnd()) + 1
' Save date and time
sentAfter = Now()
' Change mail item properties
With mi
    .To = "somebody@company.com"
    .Subject = "Please contact us"
    .Body = "Dear mr/mrs. ...."
    .Categories = id
End With
' Wait until mailitem window has been closed
While MailItemIsOpen(id)
    DoEvents
Wend
' Try to find item in Sent Items
Set mi = FindSentItem(id, sentAfter)
' E-mail has been sent
If Not (mi Is Nothing) Then
    ' Save it....
    mi.SaveAs "C:\sentmail.msg", Outlook.OlSaveAsType.olMSG
End If