Automatic excel mail word email body

[Smaxls]

Hi


I am quite new to vba, and I want to code a tool that sends out emails, and so far I managed, but here is the catch:

I have to use pictures in the email body.

No matter how hard I tried to copy a docx's content directly to the email body, it does not seem to work...

Could you please help me with this issue, I could really use some help.

I'll provide my code, its a bit lengthy, I hope its readable.

Sub Send_MAIL(Repeat As Boolean)



'/////////////////////////////////////////
'/////////// Declare variables ///////////
'/////////////////////////////////////////


    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim fromfield As Range
    Dim Emailto As Range
    Dim Emailbody As Range
    Dim Supplier As Range
    Dim cntr As Integer
    Dim accountindex As Integer


'/////////////////////////////////////////
'/////// Declare Outlook variables ///////
'/////////////////////////////////////////


    Dim OutlookApp As Outlook.Application
    Dim OutlookMail As Outlook.MailItem
    Dim oAccount As Outlook.Account
    Dim checkifaccountexists As Boolean
    
    
    Dim bmk As Bookmark


'//////////////////////////////////////
'/////// Declare Word variables ///////
'//////////////////////////////////////


    Dim wd As Object
    Dim doc As Object
    Dim editor As Object
    Dim reachpath As String
    

'/////////////////////////////////////////
'////// Error handler and unprotect //////
'/////////////////////////////////////////


    On Error Resume Next
    
    If Repeat = False Then
        Worksheets("Email_Data").Activate
        ActiveSheet.Unprotect Password:="asdasd"
    End If

              
'////////////////////////////////////////////////
'/////////// Set email part variables ///////////
'////////////////////////////////////////////////
    
    
    Set Emailfrom = Worksheets("Email_Data").Range("B1")
    Set Emailto = Worksheets("Email_Data").Range("B3")
    Set Emailcc = Worksheets("Email_Data").Range("B5")
    Set Emailbcc = Worksheets("Email_Data").Range("B7")
    Set Emailsubj = Worksheets("Email_Data").Range("B9")
    Set Emailbody = Worksheets("Email_Data").Range("B11")
    
    If Repeat Then
    Emailattach = Environ("USERPROFILE") & "\Downloads\EmailData\Attachment\" & atch_filename
    Else
    atch_filename = InputBox("Please enter the file's name and extension you want to attach", "Attachment selector", "Example: Myattachment.docx")
    Emailattach = Environ("USERPROFILE") & "\Downloads\EmailData\Attachment\" & atch_filename
    End If
    

'///////////////////////////////////////////////////////////////
'//// Check wether you are logged in to the seneder account ////
'///////////////////////////////////////////////////////////////
        
        
    For Each oAccount In Outlook.Application.Session.Accounts
        cntr = cntr + 1
        If oAccount = Emailfrom Then
            checkifaccountexists = True
            accountindex = cntr
        End If
    Next
        
        
        
    If checkifaccountexists Then
    
    
'////////////////////////////////////////////////
'/////// Check if bcc list longer than 500 //////
'////////////////////////////////////////////////
    
    
    Worksheets("Email_Data").Activate
    
    If lstCounted = 0 Then
    
    lstCountedTracker = 2
    lstCounted = Cells(499, 8).Row
    
    Else
    lstCountedTracker = lstCounted
    lstCounted = lstCounted + 499
    
    End If
    
    
    
'/////////////////////////////////////////////
'////// set bcc according to the length //////
'/////////////////////////////////////////////
    
    
    Dim Recipients As String
        
    Worksheets("Email_Data").Activate
    Cells(lstCountedTracker, 8).Activate
        
    Do While ActiveCell.Row <= lstCounted
        'If (ActiveCell.Offset(0, -2) = "X" Or ActiveCell.Offset(0, -2) = "x") And ActiveCell.Value <> "" Then
        If ActiveCell.Value <> "" Then
                
            Recipients = Recipients & ActiveCell.Value & "; "
            ActiveCell.Offset(1, 0).Activate
                    
        Else:
            ActiveCell.Offset(1, 0).Activate
                  
        End If
    Loop
            
    Emailbcc = Recipients
    
    
'////////////////////////////////////////////////
'////////// Set X to Sent where needed //////////
'////////////////////////////////////////////////
        
        
    If Repeat = False Then
    
        Call CopyEmailDataToLogs
        
        
        Worksheets("Email_Data").Activate
        Range("H2").Activate
        
        Do While ActiveCell.Value <> "" Or ActiveCell.Offset(0, -1).Value <> ""
            If (ActiveCell.Offset(0, -2) = "X" Or ActiveCell.Offset(0, -2) = "x") And ActiveCell.Value <> "" Then
                
                ActiveCell.Offset(0, -2) = "Sent"
                ActiveCell.Offset(1, 0).Activate
                    
            Else:
                ActiveCell.Offset(1, 0).Activate
                  
            End If
        Loop
        
        Call statuslogging
    
    End If
    
    
    
'////////////////////////////////////////////////////////////////////////////////
'////// Check if the recipients are still > 500, set variables accordingly //////
'////////////////////////////////////////////////////////////////////////////////
    
    
    If Cells(lstCounted, 8).Value = 0 And lstCounted <> 2 Then
    
    Repeat = False
    lstCounted = 0
    
    Else
    
    Repeat = True
    
    End If
    
    

    
    
'////////////////////////////////////////////////
'///////// Word doc variables for email /////////
'////////////////////////////////////////////////
    
    Call ClearClipboard
    Set wd = CreateObject("Word.Application")
    reachpath = Environ("USERPROFILE") & "\Downloads\EmailData\bbb.docx"
    Set doc = wd.documents.Open(reachpath)
    wd.Visible = True
    Application.Wait (Now + "00:00:03")
    doc.Activate
    Set bmk = ActiveDocument.bookmarks("bm2")
    bmk.Range.Copy
    'doc.Content.Copy
    
    
'//////////////////////////
'////// Send emails  //////
'//////////////////////////


        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
                
                
        With OutlookMail
                .SendUsingAccount = OutlookApp.Session.Accounts(accountindex)
                '.To = Emailto
                '.CC = Emailcc
                .BCC = Emailbcc
                .Subject = Emailsubj
                .VotingOptions = "Accept;Reject"
                .Attachments.Add Emailattach
                .Display
                Set editor = .GetInspector.WordEditor
                editor.Content.Paste
                'MsgBox ("Click to go on next email")
                
        End With
            
        Call ClearClipboard
        wd.Quit
        doc.Close 0
        Set wd = Nothing
        Set OutlookMail = Nothing
        Set OutlookApp = Nothing
        Application.Wait (Now + "00:00:03")
    Else
        MsgBox fromfield & " was not found in current Outlook session! Please correct your Outlook account name in Excel. If you have just created new account, restart Outlook and then try again. "
        End
    End If
        

'////////////////////////////
'////// Protect sheets //////
'////////////////////////////

    If Repeat Then
    
    Call Send_MAIL(True)
    
    Else
    
        Worksheets("Email_Data").Activate
        ActiveSheet.Protect Password:="asdasd"
        atch_filename = ""
        lstCounted = 0
    
    End If
    
        
End Sub