OLa, olha eu de novo aqui.

Abaixo segue meu codigo que uso, porem quero adaptar o mesmo para que no corpo do email apareça a imagem do produto que estou anunciando.
Estou tendo um erro nesta linha:

'A celula F21 = o endereco onde se encontra a imagem
.Attachments.Add Sheets("Email Em Massa").Range("F21").Value, olByValue, 0

Se novamente puderem ajudar agradeço

Andre

 Sub Enviar_Email_Clientes_Em_Massa()
 
 Dim Conta As String
 Dim Titulo As String
 Titulo = "Suplementos FazerBem"
 
 If Range("I3").Value = 5 Then
 MsgBox "TIPO DE MENSAGEM NÃO IDENTIFICADA, SELECIONE (1,2,3 ou 4)"
 GoTo Fim
 End If
 
If Range("H17").Value = "" Or Range("H17").Value = "" Then
 MsgBox "TÍTULO OU CORPO DA MENSAGEM EM BRANCO !"
 GoTo Fim
 End If
 
 If Range("F6").Value = 0 Then
 Sdest = Range("G6").Value
 GoTo Individual
End If


resultado = MsgBox("Deseja enviar E-mails em massa (SIM) ou (NÃO) ?", vbYesNo, "Tomando uma Decisão")
If resultado = vbNo Then
GoTo Fim
Else
End If

Individual:

Conta = "fazerbemrj@gmail.com"

'Baseado no código disponibilizado em: http://www.a1vbcode.com/snippet-3691.asp
'Function EnviaEmail2()
    Dim iMsg, iConf, Flds
 
    'Seta as variáveis, lembrando que o objeto Microsoft CDO deverá estar habilitado em Ferramentas->Referências->Microsoft CDO for Windows 2000 Library
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    Set Flds = iConf.Fields
 
    'Configura o componente de envio de email
    schema = "http://schemas.microsoft.com/cdo/configuration/"
    Flds.Item(schema & "sendusing") = 2
    'Configura o smtp
    Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
    'Configura a porta de envio de email
    Flds.Item(schema & "smtpserverport") = 465
    Flds.Item(schema & "smtpauthenticate") = 1
    'Configura o email do remetente
    Flds.Item(schema & "sendusername") = Conta
    'Configura a senha do email remetente
    Flds.Item(schema & "sendpassword") = "xxxxxxxxxxxxx"
    Flds.Item(schema & "smtpusessl") = 1
    Flds.Update
    
 If Range("F6").Value = 0 Then
 GoTo Individual_1
End If
    
'------------------------------------------------------------------
'Zerar Marcador

If Range("F13").Value = 10 Then
Range("F13").Value = ""
Else
End If
'------------------------------------------------------------------
'Marcador 1

If Range("F13").Value = "" Then
Range("F13").Value = 1
         For iCounter = 1 To WorksheetFunction.CountA(Columns(13))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 13).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 2

If Range("F13").Value = 1 Then
Range("F13").Value = 2
   If Range("O1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         For iCounter = 1 To WorksheetFunction.CountA(Columns(15))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 15).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 3

If Range("F13").Value = 2 Then
Range("F13").Value = 3
   If Range("Q1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         For iCounter = 1 To WorksheetFunction.CountA(Columns(17))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 17).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 4

If Range("F13").Value = 3 Then
Range("F13").Value = 4
   If Range("S1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         For iCounter = 1 To WorksheetFunction.CountA(Columns(19))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 19).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 5

If Range("F13").Value = 4 Then
Range("F13").Value = 5
   If Range("U1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         
         For iCounter = 1 To WorksheetFunction.CountA(Columns(21))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 21).Value
       
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 6
  
If Range("F13").Value = 5 Then
Range("F13").Value = 6
   If Range("W1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         
         For iCounter = 1 To WorksheetFunction.CountA(Columns(23))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 23).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 7
  
If Range("F13").Value = 6 Then
Range("F13").Value = 7
   If Range("Y1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         
         For iCounter = 1 To WorksheetFunction.CountA(Columns(25))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 25).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 8
  
If Range("F13").Value = 7 Then
Range("F13").Value = 8
   If Range("AA1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         
         For iCounter = 1 To WorksheetFunction.CountA(Columns(27))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 27).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 9

If Range("F13").Value = 8 Then
Range("F13").Value = 9
   If Range("AC1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         
         For iCounter = 1 To WorksheetFunction.CountA(Columns(29))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 29).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
'Marcador 10

If Range("F13").Value = 5 Then
Range("F13").Value = 6
   If Range("AE1").Value = "" Then
   Range("F13").Value = ""
   GoTo Fim
   End If
         
         For iCounter = 1 To WorksheetFunction.CountA(Columns(31))
       
       ' Sheets("Email").Select
               Sdest = Sdest & ";" & Cells(iCounter, 31).Value
       Next iCounter
GoTo Pule
End If
'------------------------------------------------------------------
  
Pule:
Individual_1:

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

 ' Range("s6").Value = Cliente
  
    With iMsg
        'Email do destinatário
        .BCC = Sdest   'Cliente
        'Seu email
        .From = Conta
        'Título do email
        .Subject = Titulo
        'Mensagem do e-mail, você pode enviar formatado em HTML
'--------------------------------------------------------------------------
' Cliente Produto Destaque

 If Range("I3").Value = 1 Then
                
        .HTMLBody = "Caro(a) Cliente," & "<br><br>" & _
                    "Produto em Destaque !" & "<br>" & _
                    Range("F19") & "<br><br>" & _
                    Range("F22") & "<br><br>" & _
                    Range("F25") & "<br><br>" & _
                    "Atenciosamente, André Luiz" & "<br>" & _
                    "Rua General Galieni, 20 loja B" & "<br>" & _
                    "Bonsucesso / Higienópolis" & "<br>" & _
                    "Fone: (21) 3564-2347" & "<br>" & _
                    "Whatsapp/Telegram: (21) 98799-3381" & "<br>" & _
                    "www.fazerbem.com.br"
GoTo Envia
End If
'--------------------------------------------------------------------------
' Cliente Ofertas
 If Range("I3").Value = 2 Then
 
        .HTMLBody = "Caro(a) Cliente," & "<br><br>" & _
                    "Temos produtos com descontos muito bons, entre em nosso site, me envie um zap ou nos ligue para ficar a par dos mesmos." & "<br>" & _
                    Range("F19") & "<br><br>" & _
                    Range("F22") & "<br><br>" & _
                    Range("F25") & "<br><br>" & _
                    "Atenciosamente, André Luiz" & "<br>" & _
                    "Rua General Galieni, 20 loja B" & "<br>" & _
                    "Bonsucesso / Higienópolis" & "<br>" & _
                    "Fone: (21) 3564-2347" & "<br>" & _
                    "Whatsapp/Telegram: (21) 98799-3381" & "<br>" & _
                    "www.fazerbem.com.br"
GoTo Envia
End If
'--------------------------------------------------------------------------
' Cliente Degustação
 If Range("I3").Value = 3 Then
            
        .HTMLBody = "Caro(a) Cliente," & "<br><br>" & _
                    "Estamos fazendo DEGUSTAÇÕES na loja, venha você também !" & "<br>" & _
                    Range("F19") & "<br><br>" & _
                    Range("F22") & "<br><br>" & _
                    Range("F25") & "<br><br>" & _
                    "Atenciosamente, André Luiz" & "<br>" & _
                    "Rua General Galieni, 20 loja B" & "<br>" & _
                    "Bonsucesso / Higienópolis" & "<br>" & _
                    "Fone: (21) 3564-2347" & "<br>" & _
                    "Whatsapp/Telegram: (21) 98799-3381" & "<br>" & _
                    "www.fazerbem.com.br"
GoTo Envia
End If
'--------------------------------------------------------------------------
' Cliente Avisos
  If Range("I3").Value = 4 Then
            
        .HTMLBody = "Caro(a) Cliente," & "<br><br>" & _
                    "Avisos" & "<br>" & _
                    Range("F19") & "<br><br>" & _
                    Range("F22") & "<br><br>" & _
                    Range("F25") & "<br><br>" & _
                    "Atenciosamente, André Luiz" & "<br>" & _
                    "Rua General Galieni, 20 loja B" & "<br>" & _
                    "Bonsucesso / Higienópolis" & "<br>" & _
                    "Fone: (21) 3564-2347" & "<br>" & _
                    "Whatsapp/Telegram: (21) 98799-3381" & "<br>" & _
                    "www.fazerbem.com.br"
End If
'---------------------------------------------------------------------------
Envia:
'---------------------------------------------------------------------------
                    
        'Seu nome ou apelido
        .Sender = "Suplementos FazerBem"
        'Nome da sua organização
        .Organization = "Suplementos FazerBem"
        'email de responder para
        .ReplyTo = "fazerBemrj@gmail.com"
        'Anexo a ser enviado na mensagem


   'A celula F21 = o endereco onde se encontra a imagem 
.Attachments.Add Sheets("Email Em Massa").Range("F21").Value, olByValue, 0





        'Passa a configuração para o objeto CDO
        Set .Configuration = iConf

        'Envia o email
        .Send
    End With
 
    'Limpa as variáveis
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
'End Function

' Range("P3").Value = 5

MsgBox "Mensagens enviadas com Sucesso !"

Fim:

End Sub