jeffeson nesse mesmo diretório que citou, acredito que contenha também o arquivo assinatura em formato texto => ....jeffeson1.txt
No exemplo, a busca da assinatura é por este arquivo.
Sub MandaEmail()
Dim EnviarPara As String
Dim ComCopia As String
Dim Assunto As String
Dim Mensagem As String
Dim assPath As String
assPath = "C:UsersjeffeAppDataRoamingMicrosoftSignaturesjeffeson1.txt"
For i = 1 To 112
EnviarPara = ThisWorkbook.Sheets(1).Cells(i, 1)
ComCopia = ThisWorkbook.Sheets(1).Cells(i, 2)
Assunto = ThisWorkbook.Sheets(1).Cells(i, 3)
Mensagem = ThisWorkbook.Sheets(1).Cells(i, 4)
If EnviarPara <> "" Then
Mensagem = ThisWorkbook.Sheets(1).Cells(i, 4)
Envia_Emails EnviarPara, ComCopia, Assunto, Mensagem, assPath
End If
Next i
End Sub
Sub Envia_Emails(EnviarPara As String, ComCopia As String, Assunto As String, Mensagem As String, assPath As String)
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim assStr As String
Dim fso As Object
Dim opTxt As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Set fso = CreateObject("Scripting.FileSystemObject")
Set opTxt = fso.GetFile(assPath).OpenAsTextStream(1, -2)
assStr = opTxt.readall
With OutlookMail
.To = EnviarPara
.CC = ComCopia
.BCC = ""
.Subject = Assunto
.Body = Mensagem & vbCr & vbCr & assStr
.Send
End With
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Set fso = Nothing
Set opTxt = Nothing
End Sub
Click em se a resposta foi util!
Postado : 24/03/2018 7:49 pm