Problems With Outlook 2013 VBA To Send and Print an email


New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
We have a business need to send an email and then print the message once it has been sent.

(We operate in a regulated environment and the sent emails are stored in paper files......)

We initially tried the suggestions from

which pointed us in the right direction, but unfortunately did not actually work for us.

However, we DO have some VBA that DOES now work successfully BUT only when it is run in the code window (step-by-step).
If we run the VBA as the users will from a button on the outlook toolbar, then it fails, as the code to print the message is executed before the message is moved from the Outbox to Sent Items.

We have tried Wait statements, loops to check for the existence of the email in Sent Items etc and ALL work fine with the code window open - and all fail "in the real world".

The current code is attached - any help or suggestions gratefully received as always.

Kind regards


Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
Have you tried this timer? -

Being the forgetful type, I'd use an ItemAdd macro so i didn't have to remember to use the button. It also insures the correct message is printed. If you don't want to print every message, add a dialog asking if they want to print it.

It lookslike you are checking the subject and to field before sending
If Len(obj.To) > 0 And Len(obj.Subject) > 0 Then
you don't need that with 2010 and 2013 - they check for blank subjects and outlook won't send mail with a blank to field.

Option Explicit
 Private WithEvents Items As Outlook.Items
  Dim strDirectory As String
 Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
  "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 Private Sub Application_Startup()
 Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
 End Sub

 Private Sub Items_ItemAdd(ByVal Item As Object)
  Dim intUserAnswer As Integer
Dim i As Long
  If TypeOf Item Is Outlook.MailItem Then
  If Item.Attachments.Count > 0 Then
  Select Case Item.Attachments.Count
  Case 1
  intUserAnswer = MsgBox("There is " & CStr(Item.Attachments.Count) & " attachment to this email. Do you wish to print it ?", vbYesNo)
  Case Else
  'More than one attachment
  intUserAnswer = MsgBox("There are " & CStr(Item.Attachments.Count) & " attachments to this email. Do you wish to print these ?", vbYesNo)
  End Select
  If intUserAnswer = vbYes Then
  PrintAttachments Item
  MsgBox "The attachments will not be printed"
  End If
  MsgBox "There are no attachments."
  End If

  End If
 End Sub
Public Sub PrintAttachments(Mail As Outlook.MailItem)
 On Error Resume Next
 Dim colAtts As Outlook.Attachments
 Dim oAtt As Outlook.Attachment
 Dim strFile As String
 Dim strFileType As String
strDirectory = "C:\Users\dianep\Documents\print\"
Set colAtts = Mail.Attachments
If colAtts.Count Then
  For Each oAtt In colAtts
  strFileType = LCase$(Right$(oAtt.FileName, 4))
  Select Case strFileType
  Case ".xls", ".doc", "xlsx", ".pdf", "docx"
  strFile = strDirectory & oAtt.FileName
  oAtt.SaveAsFile strFile
  ShellExecute 0, "print", strFile, vbNullString, vbNullString, 0
  Case Else
  'Do nothing
  End Select
 End If
 End Sub
Public Sub DeleteFiles()
'Call WaitTimer
Sleep 10000
'Delete file from folder
Kill strDirectory & "*.*"
End Sub