VBA: No attachments to CC'd recipients

Use this macro to send an attachment to email addresses in the To line and CC others with just the message.

Work in progress: the attachment script needs to be changed to save it to a file share.

Sub CCNoAttachments()
    Dim objApp As Outlook.Application
    Dim objMsg As Outlook.MailItem
    Dim oItem As Object
      
    Set objApp = Application
    Set objMsg = Application.CreateItem(olMailItem)

    Set oItem = objApp.ActiveInspector.CurrentItem
        CopyAttachments oItem, objMsg
        
        objMsg.CC = oItem.CC
        objMsg.Subject = oItem.Subject
        objMsg.Body = objMsg.Body & "Sent to: " & oItem.To & vbCrLf & vbCrLf & oItem.Body
   
' This results in a nicely formatted body but may not work well if you use RTF or plain text    
       ' objMsg.HTMLBody = objMsg.Body & " Sent to: " & oItem.To & vbCrLf & vbCrLf & oItem.HTMLBody
       
       objMsg.Display
    
' Remove CC addresses
    oItem.CC = ""

     
    Set objMsg = Nothing
    Set oItem = Nothing
End Sub
 

'--------------------------

Sub CopyAttachments(objSourceItem, objTargetItem)
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
   strPath = fldTemp.Path & "\"
   For Each objAtt In objSourceItem.Attachments
      strFile = strPath & objAtt.FileName
      objAtt.SaveAsFile strFile

' include the filename, although if you only want to use the filename, using 
' oItem.Attachments.Item(i).FileName in the main macro would be better
   objTargetItem.Body = "Included file: " & objAtt.FileName

' include the full path to the file
'   objTargetItem.Body = "Included file: " & strFile

   Next
 
   Set fldTemp = Nothing
   Set fso = Nothing
End Sub

Create the second message on Send

This macro looks at all messages you send and any message that contains an attachment is processed. The CC'd members receive a copy of the message with the attachment filename(s) and a list of people the message was sent to.

Note: This macro applies to all messages with attachments, which includes images in signatures.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objApp As Outlook.Application
    Dim objMsg  As Outlook.MailItem
    Dim i As Long
    Dim strFile As String
      
    Set objApp = Application
    Set objMsg = Application.CreateItem(olMailItem)

If Item.Attachments.Count > 0 Then

For i = 1 To Item.Attachments.Count
strFile = Item.Attachments.Item(i).FileName & "; " & strFile
Next i

        objMsg.CC = Item.CC
        objMsg.Subject = Item.Subject
        objMsg.HTMLBody = strFile & " Sent to: " & Item.To & vbCrLf & vbCrLf & Item.HTMLBody
        objMsg.Send
    
' Remove CC addresses
    Item.CC = ""

' End If
End If
     
    Set objMsg = Nothing
End Sub

Related Posts:

1. 

   Reply or ReplyAll with Attachments
2. 

   Copy Selected Occurrence to an Appointment
3. 

   Send an email when an Appointment reminder fires
4. 

   Save and Open an Attachment using VBA