Aqui
'Adicione estas linhas
Dim sQualEmail
sQualEmail = Plan1.Range("A80").Value
e depois troque :
.To = "[email protected]"
por esta :
.To = sQualEmail
[]s
Nao deu certo o sQualEmail, pois coloquei o email: [email protected] na aba Plan2 ( A1 ) , e o unico email que recebi foi na conta onde esta .C/C
fiz algo de errado ?
Option Explicit
Sub Enviar_Email_com_PDF_Planilhnado()
'========================================================
'Essa macro requer que sejam acrescentadas as referências
'Microsoft Outlook 12.0 (ou maior) Object Library
'Microsoft Scriping Runtime
'========================================================
Dim OL As Object
Dim EmailItem As Object
Dim Wb As Workbook
Dim sQualEmail
sQualEmail = Plan2.Range("A1").Value
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
ActiveSheet.UsedRange.Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ActiveWorkbook.Path & "Temp.pdf", Quality:=xlQualityStandard _
, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish _
:=False
With EmailItem
.Subject = "Seu Pedido Gauer do Brasil"
.Body = "Segue anexo seu Pedido para Aprovação." & vbCrLf & _
"" & vbCrLf & _
"Obrigado!" & vbCrLf & _
"" & vbCrLf & _
"André Luiz" & vbCrLf & _
"Fone: (21)3564-2347" & vbCrLf & _
"WhatsApp: (21)98799-3381" & vbCrLf & _
"[email protected]"
.To = sQualEmail
.CC = "contato@fazerbem.com.br"
.Importance = olImportanceNormal
.Attachments.Add ActiveWorkbook.Path & "Temp.pdf"
.Send
MsgBox "RELATÓRIO ENVIADO COM SUCESSO!", vbInformation, "ENVIADO"
End With
Application.ScreenUpdating = True
Set Wb = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Call ApagarArquivoTemporário(ActiveWorkbook.Path & "")
End Sub
Sub ApagarArquivoTemporário(ByVal Caminho As String)
'Desabilita a atualização automática
Application.EnableEvents = False
'Declaração de variáveis
Dim fso As Scripting.FileSystemObject
Dim fld As Scripting.Folder
Dim fl As Scripting.File
'Aqui é criado o objeto que comunica com as pastas do computador
Set fso = CreateObject("Scripting.FileSystemObject")
'Esse objeto executa um método do FileSystemObject
'para buscar atribuir à variável fld uma pasta
Set fld = fso.GetFolder(Caminho)
'Loop em cada elemento (ou seja, arquivo) do caminho desejado:
For Each fl In fld.Files
'Verifica se é um arquivo com extensão PDF
If Right(fl.Name, 3) = "PDF" Or Right(fl.Name, 3) = "pdf" Then
fl.Delete
End If
Next
'Habilita a atualização automática
Application.EnableEvents = True
End Sub
Postado : 04/12/2015 9:14 am