Problems With Outlook 2013 VBA To Send and Print an email

[Horatio_too]

Hi
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

https://forums.slipstick.com/threads/90476-button-to-send-and-print-emails/

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
Horatio_too

 

[Diane Poremsky]

Have you tried this timer? - http://www.vboffice.net/en/developers/pause-code-execution

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
  
  Item.PrintOut
  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
  Else
  MsgBox "The attachments will not be printed"
  End If
  Else
  MsgBox "There are no attachments."
  End If

  End If
DeleteFiles
 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
  Next
 End If
 End Sub
Public Sub DeleteFiles()
'Call WaitTimer
Sleep 10000
'Delete file from folder
Kill strDirectory & "*.*"
End Sub