none
Envio automático de e-mail RRS feed

  • Pergunta

  • Boa Tarde a todos!

    Estou com uma planilha VBA para envio automatico de informações no corpo do e-mail. Estou usando o seguinte código:

    Sub MandaEmail()
    Dim EnviarPara As String
    Dim Mensagem As String


    For i = 1 To 13

        EnviarPara = ThisWorkbook.Sheets(1).Cells(i, 1)
        If EnviarPara <> "" Then
            Mensagem = ThisWorkbook.Sheets(1).Cells(i, 3) & Sheets(5).Cells(5, 3) & " " & Sheets(5).Cells(5, 10) & " " & Sheets(5).Cells(5, 9) & "   " & Sheets(5).Cells(5, 7) & vbCrLf & Sheets(5).Cells(6, 3) & " " & Sheets(5).Cells(6, 10) & " " & Sheets(5).Cells(6, 9) & "   " & Sheets(5).Cells(6, 7) & vbCrLf & Sheets(5).Cells(7, 3) & " " & Sheets(5).Cells(7, 10) & " " & Sheets(5).Cells(7, 9) & "   " & Sheets(5).Cells(7, 7)
            Envia_Emails EnviarPara, Mensagem
        End If

    Next i


    End Sub





    Sub Envia_Emails(EnviarPara As String, Mensagem As String)
        Dim OutlookApp As Object
        Dim OutlookMail As Object
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = EnviarPara
            .CC = ""
            .BCC = ""
            .Subject = "Cobrança Cartão Corporativo"
            .Body = Mensagem
            .Display ' para envia o email diretamente defina o código  .Send
        End With
        Set OutlookMail = Nothing
        Set OutlookApp = Nothing
    End Sub

    Na parte "Mensagem" em que eu seleciono as células que estarão no corpo do e-mail, a formatação original da planilha não vem junto delas e eu preciso que esteja na mesma formatação, pois no corpo do e-mail as informações ficam estranhas sem a formatação original.

    E também caso tenha uma forma melhor de selecionar as células, seria melhor, pois o código ficou muito grande  e não consigo continuar na linha abaixo para selecionar mais células.

    Grato desde já.

    segunda-feira, 12 de março de 2018 20:26

Todas as Respostas

  • Para a formatação das celulas sejam aplicadas no corpo do e-mail voce pode usar o recurso Envelope do Excel. ou minhas sugestão é utilizar a função RangetoHTM, que converte o intervalo de células para html. 

    Mas como os dados que compõe a mensagem estão em células separadas e planilhas diferentes, crie uma nova planilha(aba) ou em alguma coluna em uma planilha existente e crie este intervalo agrupando as células: 

    Sheets(1).Cells(i, 3)
    Sheets(5).Cells(5, 3)
    Sheets(5).Cells(5, 10)
    Sheets(5).Cells(5, 9)
    Sheets(5).Cells(5, 7)
    Sheets(5).Cells(6, 3)
    Sheets(5).Cells(6, 10)
    Sheets(5).Cells(6, 9)
    Sheets(5).Cells(6, 7)
    Sheets(5).Cells(7, 3)
    Sheets(5).Cells(7, 10)
    Sheets(5).Cells(7, 9)
    Sheets(5).Cells(7, 7)

    E Formate como desejar. No código referencie este intervalo, criado no local indicado.

    Sub MandaEmail()
    Dim EnviarPara As String
    Dim Mensagem As Range
    
    For i = 1 To 13
    
        EnviarPara = ThisWorkbook.Sheets(1).Cells(i, 1)
        If EnviarPara <> "" Then
                    ' Altere Abaixo com o local dados Agrupados e formatados
      Set Mensagem = ThisWorkbook.Sheets("Sua_Planilha").Range("A1:A3")
      
            Envia_Emails EnviarPara, Mensagem
        End If
    
    Next i
    
    
    End Sub
    
    
    Sub Envia_Emails(EnviarPara As String, Mensagem As Range)
        Dim OutlookApp As Object
        Dim OutlookMail As Object
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = EnviarPara
            .CC = ""
            .BCC = ""
            .Subject = "Cobrança Cartão Corporativo"
            .HTMLBody = RangetoHTML(Mensagem)
            .Display ' para envia o email diretamente defina o código  .Send
        End With
        Set OutlookMail = Nothing
        Set OutlookApp = Nothing
    End Sub
    
    Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.readall
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    End Function


    Fonte: https://www.rondebruin.nl/win/s1/outlook/bmail2.htm


    Click em propor como resposta se foi util a voce. ricardodm@outlook.com.br


    • Editado Ricardo Vba segunda-feira, 12 de março de 2018 21:52
    segunda-feira, 12 de março de 2018 21:49