Important:

Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog podem ser tratados como consultoria freelance.

Views

Vitrine

Excel VBA - Como Enviar um Range de uma planilha pelo Outlook - How to Send a Range from an Active Sheet in an Outlook Email Body from Active Workbook with VBA

Excel VBA - Como Enviar um Range de uma planilha pelo Outlook - How to Send a Range from an Active Sheet in an Outlook Email Body from Active Workbook with VBA

Este código envia o conteúdo de um Range no corpo do e-mail do Outlook.

Sub Mail_Selection_Range_Outlook_Body()
    Dim Rng As Range
    Dim OutlookApp As Object
    Dim NewMail As Object

    Set Rng = Nothing
    On Error Resume Next

    Set Rng = ActiveSheet.Range("MyRng")
'--Se desejar, pode utilizarum Range fixo
    'Set Rng = Sheets("YourSheet").Range("A1:D12").SpecialCells(xlCellTypeVisible)


    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "Não foi realizada a seleção de um Range ou a Planilha está protegida." & _
               vbNewLine & "Por favor, corrija e comece novamente.", vbOKOnly
        Exit Sub
    End If

    With Application
        Let .EnableEvents = False
        Let .ScreenUpdating = False
    End With

    Set OutlookApp = CreateObject("Outlook.Application")
    Set NewMail = OutlookApp.CreateItem(olMailItem)
    'Set NewMail = OutlookApp.CreateItem(0)
    
 '--Inserindo uma assinatura no corpo do Email
 '--Mude somente 'YourSignature.htm' no nome da sua assinatura
    Let SigString = Environ("appdata") & "\Microsoft\Signatures\Tamatam.htm"

    If Dir(SigString) <> "" Then
        Let Signature = GetBoiler(SigString)
    Else
        Let Signature = ""
    End If

 '--Selecione a conta de Email de onde deseja enviar
 '--Caso sua conta não seja seu perfil, precisará usar SentOnBehalfOfName
        For I = 1 To OutlookApp.Session.Accounts.Count
            If OutlookApp.Session.Accounts.Item(I) = "MyEmailAccountAlias@Domain.Com" Then
             MsgBox OutlookApp.Session.Accounts.Item(I) & " : This is account number " & I
                Let Acn_No = I
                Exit For
            End If
        Next I

'--Definindo o corpo do Email
        Strbody = "<H3><B>TEST MAIL via EXCEL MACRO</B></H3>" & _
                    "Este é um exemplo teste de envio de email por código VBA<br>" & _
                    "Por favor não o responda<br>" & _
                    "<A href=""http://brzexceldeveloper.blogspot.com.br//"">✔ Brazil VBA Excel Specialist®</A>"
              
    On Error Resume Next

'--Abre um novo Email para envio
    With NewMail
        Let .TO= "YourEmail@Domain.com" '-- O Email de destino é digitado aqui
        
Let .CC = ""
        Let .Subject = "Test Message" '--O assunto do Email é colocado aqui
       'Let .Body = "This Your Email Boday ; '--Pode colocar este código abaixo também
        Let .HTMLBody Strbody & "<br>" & "<br>" & _
                    RangetoHTML(Rng) & "<br>" & "<br>" & _
                    "<B>Obrigado</B>" & "<br>" & "<br>" & Signature
        
Let .SentOnBehalfOfName = OutlookApp.Session.Accounts.Item(Acn_No) 

        '--Poderá usar este código abaixo como desejar
        '
Let .SentOnBehalfOfName = "MyEmailAccountAlias@Domain.Com"
        'Let .SendUsingAccount = OutlookApp.Session.Accounts.Item(Acn_No)

        Let .Display '--Mostre o email antes de enviá-lo, se desejar.
        Let .BCC "brazilsalesforceeffectiveness@gmail.com"
        Let .Send
    End With
    
    On Error GoTo 0

    With Application
        Let .EnableEvents = True
        Let .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

A função abaixo criará um arquivo temporário contendo o Range da planilha ativa como um arquivo .htm, colocando-o a seguir no corpo do Email da mensagem

Function RangetoHTML(Rng As Range)
    Dim FSO As Object
    Dim TS As Object
    Dim TempFile As String
    Dim TempWB As Workbook

'--Criando um arquivo .htm temporário para copiar o Range da planilha ativa.
    'Let TempFile = Environ$("temp") & "\" & Format(Now, "dd-mmm-yyyy") & ".htm"
     Let TempFile = Environ("UserProfile") & "\Desktop\Test\" & Format(Now, "dd-mmm-yyyy") 
                                                                                              & ".htm"

 '--Copia e cola o range com os dados para uma nova planilha criada
    'Rng.Select
    Rng.Copy
    Set TempWB = Workbooks.Add(xlWBATWorksheet)

'--Copia e cola o conteúdo do Range da planilha ativa para a planilha temporária
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8 'Paste with same Column Widths
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Let Application.CutCopyMode = False
        On Error Resume Next
        Let .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

'--Salva o conteúdo da planilha temporária como um arquivo htm temporário
    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

 '--Lê todo o conteúdo do arquivo htm inserindo-o na variável RangetoHTML
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TS = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    Let RangetoHTML = TS.readall
    TS.Close
    Let RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

'--Fecha o TempWB
    TempWB.Close SaveChanges:=False

'--Deleta o arquivo htm usado nesta função
    Kill TempFile

    Set TS = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

-- Esta função evocará o processo responsável por resgatar a assinatura e copiá-la no corpo do email
Function GetBoiler(ByVal SigFile As String) As String
    Dim FSO As Object
    Dim TS As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TS = FSO.GetFile(SigFile).OpenAsTextStream(1, -2)
    Let GetBoiler = TS.readall
    TS.Close

End Function

Deixe seus comentários, compartilhe este artigo!


⬛◼◾▪ Social Media ▪◾◼⬛
• FACEBOOK • TWITTER • INSTAGRAM • TUMBLR • GOOGLE+ • LINKEDIN • PINTEREST

⬛◼◾▪ Blogs ▪◾◼⬛ 

⬛◼◾▪ CONTATO ▪

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...