Pegar imagem JPG e colar corpo email

fazerbem

(@fazerbem)

Posts: 697

Honorable Member

Topic starter

Bom dia, desculpem mais uma vez vir a vcs pedidndo ajuda.

A VBA abaixo está funcionando perfeitamente, somente gostaria de adicionar a mesma uma rotina em que eu pudesse pegar uma imagem dentro da pasta C:imagens e adicionar ao corpo do email antes da assinatura que esta Ok. Consegui pegar a imagem da assinatura que esta em HTM, mas nao consigo pegar a imagem que esta em JPG.

Alguem poderia me dar uma ajuda e implantar tal rotina ?

Desde ja agradeço.

Andre

[code]Option Explicit
Dim assinatura As Variant
Public Function pega_assinatura(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    pega_assinatura = ts.ReadAll
    ts.Close
End Function
Sub X_Lojas()

'  Lojas Gerais

If Sheets("CONFIG").Range("D20").Value = 1 Then
MsgBox ("Sistema de Envio Individual Selecionado !!!")
GoTo Atualizar
Else
End If


'Setting up the Excel variables.
    Dim OlApp As Outlook.Application
    Dim OlMensagem As Outlook.MailItem
    Dim iCounter    As Integer
    Dim Dest        As Variant
    Dim SDest       As String
    Dim Estado      As String
    Dim BuscaEstado As Range
    Dim AbrevEstado As String
    Dim Leitura     As String
    Dim contaEmail As String
    Dim idEmail As Integer
    Dim strbody As String
    Dim Loja        As String
    Loja = Range("A1")
    Dim Assunto     As String
    Assunto = Range("L1")
    
'--------------------------------------------------------
    Dim objMail As MailItem
    Set OlApp = Outlook.Application
    'Create mail item
    Set objMail = OlApp.CreateItem(olMailItem)
'------------------------------------------------------------

If Range("Q4").Value = "Amigo Lojista" Or Range("Q4").Value = "Vendas Energy" Then
  
      assinatura = pega_assinatura("C:AssinaturasAmigo.htm")
      
Else
      
If Range("Q4").Value = "Gauer do Brasil - André" Or Range("Q4").Value = "Vendas Gauer" Then
  
      assinatura = pega_assinatura("C:AssinaturasGauer.htm")
  
Else

      assinatura = pega_assinatura("C:AssinaturasLeader.htm")

End If
End If

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

  If Sheets(Loja).Range("K4").Value = "" Then
  MsgBox ("Qual Empresa associar esta Mensagem 1-Gauer do Brasil ou 2-Leader Nutrition ?")
  Range("K4").Select
   
 GoTo Fim
 Else
 End If
        
    
  If Sheets(Loja).Range("Q4").Value = "" Then
  MsgBox ("A conta de E-mail não foi associada !")
  
 
 GoTo Fim
 Else
 End If
    
        
 If Sheets(Loja).Range("F7").Value = 1 Then
 
 strbody = "<H2>" & _
        Sheets(Loja).Range("AD2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets(Loja).Range("AD6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets(Loja).Range("AD10").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("AD14").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("AD18").Value & _
        "<br><br>"
 
GoTo Continuar
 
Else
        
        
 If Sheets(Loja).Range("K4").Value = 1 Then
    
strbody = "<H2>" & _
        Sheets(Loja).Range("V2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets(Loja).Range("V6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets(Loja).Range("V10").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("V14").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("V18").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("V22").Value & _
        "<br><br>"
    
    Else
         
strbody = "<H2>" & _
        Sheets(Loja).Range("Z2").Value & _
        "</H2>" & _
        "<H3 style='color: #870c0c'>" & _
        Sheets(Loja).Range("Z6").Value & _
        "</H3>" & _
        "<H3>" & _
        Sheets(Loja).Range("Z10").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z14").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z18").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z22").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z23").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z24").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z25").Value & _
        "<br><br>" & _
        Sheets(Loja).Range("Z26").Value & _
        "<br><br>"

End If
End If

GoTo Continuar
Continuar:


    Leitura = Sheets(Loja).Range("I7")
    
  If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Pular2
 Else
 End If
 
 If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Pular2
 Else
 End If
 
 If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Pular2
 Else
 End If
  
  
  If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Pular2
 Else
 End If
    
  If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Pular2
 Else
 End If
    
    
    
    Estado = Application.Caller
    Application.ScreenUpdating = False
    Sheets(Estado).Visible = True

GoTo Pular2
Pular2:

 Application.DisplayAlerts = False 'desabilite o alerta

'------------------------------------------------------------
'DVitaminas/SNC/......

 If Sheets(Loja).Range("E15").Value = 1 Then
 
 GoTo Pular
Else
End If
'-----------------------------------------------------------
    Range("L2").Select

    Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A32").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)
    
    If BuscaEstado Is Nothing Then
        MsgBox "Estado não localizado"
        GoTo Fim
    Else
    
        AbrevEstado = ThisWorkbook.Worksheets(Loja).Cells(BuscaEstado.Row, 1).Value
    End If
         
GoTo Pular
Pular:
    
' Preste atencao aqui
      contaEmail = ThisWorkbook.Sheets(Loja).Range("Q4").Value
    
  If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Pular3
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Pular3
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Pular3
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Pular3
 Else
 End If
      
   If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Pular3
 Else
 End If
    
    
    'Quero que aqui, ao inves de ter RJ tenha a variavel Estado que vai estar associado ao click na     regiao do mapa.
    ThisWorkbook.Worksheets(AbrevEstado).Select
   
GoTo Pular3
Pular3:
   
   If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "SNC" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
    
   If Sheets(Loja).Range("A1").Value = "Farmacias" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
 
    If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
    
    If Sheets(Loja).Range("A1").Value = "Academias" Then
          iCounter = 2
  
 GoTo Proximo1
 Else
 End If
    
    
    iCounter = 1
   
 GoTo Proximo1
Proximo1:
   
    'Create the Outlook application and the empty email.
    Set OlApp = CreateObject("Outlook.Application")
Set OlMensagem = OlApp.CreateItem(0)

'------------------------------------------------------------------------------
   Dim W
   'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
    For W = 1 To OlApp.Session.Accounts.Count
        If OlApp.Session.Accounts.Item(W).DisplayName = contaEmail Then 'Se for verdadeiro, solicita confirmação
        
   If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Proximo
 Else
 End If
        
   If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Proximo
 Else
 End If
 
    If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Proximo
 Else
 End If

   If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Proximo
 Else
 End If
 
   If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Proximo
 Else
 End If
    
    
    If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                            
  GoTo Proximo
Proximo:
                
                idEmail = W 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
                
            Else
                 Sheets(Estado).Visible = False
                 Sheets(Loja).Select
                
                GoTo Fim 'Senão sai da rotina
            End If
        End If
    Next
'-------------------------------------------------------------------------------
 
'Using the email, add multiple recipients, using a list of addresses in column C.
     With OlMensagem
      
If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Else
End If
       
       
If Sheets(Loja).Range("A1").Value = "SNC" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Else
End If

If Sheets(Loja).Range("A1").Value = "Farmacias" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Else
End If

If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2


Else
End If

If Sheets(Loja).Range("A1").Value = "Academias" Then
     
       For iCounter = 2 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2


Else
End If
       
       
       
       For iCounter = 1 To WorksheetFunction.CountA(Columns(3))
       
       ' Sheets("Email").Select
               SDest = SDest & ";" & Cells(iCounter, 3).Value
       Next iCounter

GoTo Proximo2
Proximo2:

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



'---------------------------------------------------------------
          
    'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
       .Display
       
If Range("Q15").Value = 1 Then
       
       .BCC = SDest
       
Else

If Sheets(Loja).Range("S10").Value = 1 Then

       .BCC = SDest
       
 Else
       
       .To = SDest
       
 End If
 End If
 
       .Subject = Assunto '"Tabela de Pedidos"
'----------------------------------------------------
      .BodyFormat = olFormatHTML
'----------------------------------------------------
       .HTMLBody = strbody & assinatura & .HTMLBody
       
If Sheets(Loja).Range("F1").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F1").Value
Else
    End If

If Sheets(Loja).Range("F2").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F2").Value
Else
    End If
If Sheets(Loja).Range("F3").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets(Loja).Range("F3").Value
Else
    End If
If Sheets(Loja).Range("F4").Value > 0 Then
       .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets(Loja).Range("F4").Value
Else
    End If
       
       
     ' Sheets(s).Select
       
If Sheets(Loja).Range("I6").Value = "SEND" Then
       .ReadReceiptRequested = Leitura ' confirmação de leitura
       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
       
'-------------------------------------------------------
'Temporizador

Application.Wait VBA.Now + TimeValue("00:00:01")
'-------------------------------------------------------------

       .Send
Else

       .ReadReceiptRequested = Leitura ' confirmação de leitura
       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
       .Display
       
        
End If

Sheets(Loja).Select

  If Sheets(Loja).Range("A1").Value = "DVitaminas" Then
  
 GoTo Pular4
 Else
 End If

  If Sheets(Loja).Range("A1").Value = "SNC" Then
  
 GoTo Pular4
 Else
 End If

  If Sheets(Loja).Range("A1").Value = "Farmacias" Then
  
 GoTo Pular4
 Else
 End If

  If Sheets(Loja).Range("A1").Value = "Rio de Janeiro" Then
  
 GoTo Pular4
 Else
 End If


  If Sheets(Loja).Range("A1").Value = "Academias" Then
  
 GoTo Pular4
 Else
 End If

Sheets(Estado).Visible = False
   
GoTo Pular4
Pular4:
   
GoTo Fim


   

    Exit Sub
Fim:
   'Clean up the Outlook application.
   Set BuscaEstado = Nothing
   Set OlMensagem = Nothing
   Set OlApp = Nothing
   
   End With
   
 GoTo Atualizar
Atualizar:
 
   
End Sub[/code]

Postado : 23/06/2016 6:14 am

fazerbem

(@fazerbem)

Posts: 697

Honorable Member

Topic starter

Bem, eu encontrei o seguinte VBA na net , fiz o teste usando somente a Macro abaixo e deu certinho com o que eu procurava.

Criei uma Planilha em Branco para teste

Usei a Coluna de B1:B4 e postei:

B1 = [email protected]
B2 = [email protected]
B3 = Assunto
B4 = endereco da imagem, neste caso : C:ImagemFigura1.jpg

Rodei a Macro e caiu certo no que eu queria e agora irei adaptar a minha Macro acima, mas porem preciso agora saber como irei usar a Celula B5 e nela escrever o arquivo, neste caso ( Figura1 ), assim a imagem a ser resgatada seria o que estiver na celula B5. ( & "<img src='cid:Figura1.jpg'" & "width='936' height='724'> " _ )
Ja em B6 = Quero por ali a dimensao Width e em B7 a dimensao Height

B5 = aqui vou colocar o nome da imagem
B6 e B7 = aqui vou por a dimensao da imagem

Grato

Andre

Sub sumit()
Dim mainWB As Workbook
Dim SendID
Dim CCID
Dim Subject
Dim Body
Dim olMail As MailItem

Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor
'Dim colAttach As Outlook.Attachments
Dim oAttach As Outlook.Attachment

Set mainWB = ActiveWorkbook

SendID = mainWB.Sheets("Mail").Range("B1").Value
CCID = mainWB.Sheets("Mail").Range("B2").Value
Subject = mainWB.Sheets("Mail").Range("B3").Value
Body = mainWB.Sheets("Mail").Range("B4").Value
With olMail
    .To = SendID
    If CCID <> "" Then
      .CC = CCID
    End If
    .Subject = Subject
    'add the image in hidden manner, position at 0 will make it hidden
'    .Attachments.Add "C:AssinaturasFigura1.jpg", olByValue, 0
    .Attachments.Add Range("B4").Value, olByValue, 0

    'Now add it to the Html body using image name
    'change the src property to 'cid:your image filename'
    'it will be changed to the correct cid when its sent.
    .HTMLBody = .HTMLBody & "<br><B>TESTE</B><br>" _
                & "<img src='cid:Figura1.jpg'" & "width='936' height='724'><br>" _
                & "<br>Best Regards, <br>Sumit</font></span>"
                
    .Display
    .Display  'Send
End With

'MsgBox ("you Mail has been sent to " & SendID)

End Sub

Postado : 23/06/2016 7:38 am

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Não tenho como testar, mas de uma olhada no link abaixo, mais precisamente na Function (Function recolheImagem) que recolhe o nome da imagem para ser enviada no email, ela está implementada com um Array, e como vai utilizar somente uma é só alterar as linhas :

'celula onde colocamos a localização da imagem
imagem = Sheets("imagem").Range("B5")

eliminar o loop e alterar a linha :
imagem = "<img src="""cid:"" & recolheImagem(arrImagens(i)) & """ />"
para
imagem = "<img src="""cid:"" & recolheImagem(imagem) & """ />"

Tem tambem uma Function para Assinatura.

De uma olhada e veja se ajuda.

VBA - email com imagem
http://www.hardware.com.br/comunidade/e ... a/1300424/

[]s

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 23/06/2016 8:43 am

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Andre, fiz uns ajustes conforme a dica do site que informei e a imagem é enviada conforme o endereço em B5, só não ajustei o assunto e o texto do corpo, faça um teste primeiro e depois ajuste as outras informações, a rotina que está no site tambem funciona corretamente, você pode copia-la alterar os endereços das celulas e testar.
As instruções que estão desabilitadas nesta rotina não sei o porque mas davam erro aqui, mas deixei que pode ser que pra você não precise desabilita-las.

Sub Submit_Mauro()
    Dim mainWB As Workbook
    Dim SendID
    Dim CCID
    Dim Subject
    Dim Body
    Dim olMail 'As MailItem
    Dim imagem, arrImagens
    
    Set otlApp = CreateObject("Outlook.Application")
    Set olMail = otlApp.CreateItem(olMailItem)
    Set Doc = olMail.GetInspector.WordEditor
    
    'Dim colAttach As Outlook.Attachments
    'Dim oAttach As Outlook.Attachment

    Set mainWB = ActiveWorkbook

    SendID = mainWB.Sheets("Mail").Range("B1").Value
    CCID = mainWB.Sheets("Mail").Range("B2").Value
    Subject = mainWB.Sheets("Mail").Range("B3").Value
    Body = mainWB.Sheets("Mail").Range("B4").Value
    
    'celula onde colocamos a localização da imagem
    imagem = mainWB.Sheets("Mail").Range("B5").Value
    
    With olMail
        .To = SendID
        If CCID <> "" Then
          .CC = CCID
        End If
        .Subject = Subject
        
        'tratar imagens para inserir no email
        If Len(imagem) > 0 Then
        
            arrImagens = Split(imagem, ";")
            imagem = "<p>imagem</p>"
        
            For i = LBound(arrImagens) To UBound(arrImagens)
                If Dir(arrImagens(i)) <> "" Then
                    .Attachments.Add arrImagens(i)
                    imagem = "<p><img src="""cid:"" & recolheImagem(arrImagens(i)) & """ /></p>"
                End If
            Next i
    
        End If
                   
         'Corpo da msg com a imagem
        .HTMLBody = "<html>" & "<font color=#3333FF><font face=calibri><font size=2><body>Senhores,<br /><br>" _
        & "Seguem abaixo os resultados de hoje.<br /><br>" & imagem & "<br />" & Assinatura & "</body></html>"
        
        .Display
        .Display  'Send
    
    End With

    'MsgBox ("you Mail has been sent to " & SendID)

    End Sub


' Função que retira o caminho da imagem deixando só o nome desta,
' é usado para inserir a imagem no email.
' Ex: c:imagensimagem.jpg
' fica: imagem.jpg
Function recolheImagem(stImagem)
    Dim x, ultimo_x
    'vamos buscar só o nome da imagem
    x = InStr(1, stImagem, "")
    
    Do
        ultimo_x = x
        x = InStr(x + 1, stImagem, "")
    Loop Until x = 0
    
    recolheImagem = Mid(stImagem, InStr(ultimo_x, stImagem, "") + 1, Len(stImagem))

End Function

' Função usada para tratar o pedido de inserção de assinatura
Function Assinatura()
    Dim fAssinatura, stAssinatura, stLinha
    
    fAssinatura = Environ("APPDATA") & "MicrosoftSignatures" & Range("C15")
    stAssinatura = ""
    
    If Dir(fAssinatura) <> "" Then
        Open fAssinatura For Input As #1
    Do While Not EOF(1)
        Line Input #1, stLinha
            stAssinatura = stAssinatura & vbCrLf & stLinha
    Loop
        Close #1
    End If
    
    Assinatura = stAssinatura
    
End Function

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 23/06/2016 11:36 am

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Andre, estava pesquisando um pouco mais e acabei encontrando de onde você tirou a rotina :

Excel-VBA : Send Mail with Embedded Image in message body From MS Outlook using Excel.
http://excel-macro.tutorialhorizon.com/ ... ing-excel/

Se você tivesse olhado mais abaixo neste site teria encontrado a resposta que precisa :
Excel-VBA : Send Unique Images Embedded to Mail Body, With Every Mail From MS Outlook using Excel.
http://excel-macro.tutorialhorizon.com/ ... ing-excel/

De uma olhada, mas pelo que vi ela tambem utiliza uma Function para Adicionar a Imagem Function AddImage(strFile)

[]s

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 23/06/2016 1:31 pm