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
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!
⬛◼◾▪ CONTATO ▪◾◼⬛
