VBA - Attaching Files embedded in a worksheet to an email through VBA

JonnShea 

I do not see an obvious error in your code. I cleaned it up some (see below), and have it working for me, for eight files (of seven different file types).  I did not use the CC feature.  I also added error handling code, as you say this is/will be used by others.

Are you perhaps using a very old version of Outlook? (My version of Outlook is 2305, referenced by the VBA project via the "Microsoft Outlook 16.0 Object Library").

Do any of the files exceed your attachment size limit? Or do they in combination exceed the limit?

You do not mention any error message, so I'll assume there was none.  So in the code below, I capture a reference to each generated Attachment object, and include a Debug.Assert statement immediately after; execution will stop if such an object is not created.

Sub CreateDrafts()
'   This macro generates draft emails for the recipients in column
'       V (22), starting from row 5 down until a blank cell is
'       encountered, but only for cells with email addresses that
'       are highlighted in (pure) yellow.

    'Declare variables
    Dim strActionInProgress As String
    Dim objRecipientSheet   As Worksheet
    Dim objAttachmentSheet  As Worksheet
    Dim objOutlook  As Outlook.Application
    Dim objMail     As Outlook.MailItem
    Dim strTo       As String
    Dim strCC       As String
    Dim strSubject  As String
    Dim strBody     As String
    Dim strSharedMailbox    As String
    Dim strEmailAddress     As String   'for a recipient
    Dim rngAttachmentCell   As Range
    Dim strFileToAttach As String
    Dim objAttachment   As Outlook.Attachment
    Dim in4Row  As Long '[Integer only goes up to 32,767]
    
    '----   Capture a reference to the active worksheet.  (This
    '       avoids problems if the user clicks on a different sheet
    '       while this macro is executing.)
    Set objRecipientSheet = ActiveSheet
    
    '----
    On Error GoTo CreateDraft_ErrHndlr
    strActionInProgress = "gathering info"
    Set objAttachmentSheet = ThisWorkbook.Worksheets("HiddenSheet")
    
    'Set variables
    strTo = strEmailAddress
    strSharedMailbox = "SharedMailbox@_____.com"
    strCC = "Boss@____.com; Me@____.com"
    strSubject = "This is the subject of the email"
    strBody = "This is the body of the email" & " " _
            & vbCrLf & "Signed, ________"
    
    '----   Create an instance of Outlook.
    strActionInProgress = "opening Outlook"
    Set objOutlook = New Outlook.Application
    
    '----   Generate draft emails for cells that qualify.
    in4Row = 5   'the starting row
    ' Check if cell in column V is not empty
    Do While Len(objRecipientSheet.Cells(in4Row, 22).Value) > 0
        ' Check the cell's backgound color.
        If objRecipientSheet.Cells(in4Row, 22).Interior.Color _
                = RGB(255, 255, 0) Then  '= yellow
            ' Grab the email address.
            strActionInProgress = "getting recipient info"
            strEmailAddress = objRecipientSheet.Cells(in4Row, 22).Value
            
            'Create a new email.
            strActionInProgress = "creating a MailItem object"
            Set objMail = objOutlook.CreateItem(olMailItem)
            
            'Set the MailItem properties.
            strActionInProgress = "populating the Mail object"
            objMail.To = strEmailAddress
            objMail.SentOnBehalfOfName = strSharedMailbox
            objMail.CC = strCC
            objMail.Subject = strSubject
            objMail.Body = strBody
            
            ' Add the attachments - TEST 3
            strActionInProgress = "accessing file list"
            For Each rngAttachmentCell In objAttachmentSheet.Range("A1:A8")
                strActionInProgress = "accessing file list"
                strFileToAttach = rngAttachmentCell.Value
                If strFileToAttach <> "" Then
                    strActionInProgress = "attaching a file"
                    Set objAttachment = objMail.Attachments.Add( _
                            strFileToAttach, olByValue)
                    Debug.Assert (objAttachment Is Nothing) = False
                End If
            Next rngAttachmentCell
            
            'Draft email
            strActionInProgress = "saving the draft"
            objMail.Close olSave
            
            'Release the object reference.
            Set objMail = Nothing
        End If
        
        'Advance to the next row.
        in4Row = in4Row + 1
    Loop
    
    'Show confirmation message to user
    MsgBox "Done", vbInformation
CreateDraft_Exit:
    '   Dereference external objects. [less likely important for
    '   internal objects]
    Set objAttachment = Nothing
    Set objMail = Nothing
    Set objOutlook = Nothing
    
    Exit Sub

CreateDraft_ErrHndlr:
    Dim in4ErrorCode    As Long
    Dim strErrorDescr   As String
    Dim strMessage  As String
    Dim in4UserResponse As VbMsgBoxResult
    '  --   Capture information about the error (exception).
    in4ErrorCode = Err.Number
    strErrorDescr = Err.Description
    '  --   Notify the user.
    strMessage = "Error " & CStr(in4ErrorCode) & " occurred while " _
            & strActionInProgress
    If Len(strEmailAddress) > 0 Then
        strMessage = strMessage & " for " & strEmailAddress
    End If
    strMessage = strMessage & ":" & vbCrLf & strErrorDescr _
            & vbCrLf & vbCrLf & strFileToAttach
    in4UserResponse = MsgBox(strMessage, vbExclamation Or vbRetryCancel _
            , "CreateDrafts")
    '  --   Recover from the error.
    If in4UserResponse = vbRetry Then
        Debug.Assert False  '...for debugging only
        Resume
    ElseIf in4UserResponse = vbCancel Then
        Resume CreateDraft_Exit
    End If
End Sub