Olá pessoal, boa tarde!
Segue o código abaixo, conto com a ajuda de Vcs, muito obrigado!
Sub MalaDiretaEnviarEmailCorpo()
'Defina aqui em qual coluna se encontra o campo Email
Const cEmail As String = "D"
'Declarações para o Outlook
Dim appOutlook As Outlook.Application
Dim olMI As Outlook.MailItem
Dim ws As Worksheet
Dim n As Long
Dim r As Long, rLast As Long
Dim c As Long, cLast As Long
Dim appWord As Word.Application
Dim doc As Word.Document
Dim blOutlookWasClosed As Boolean
Set ws = ActiveSheet
'Obter ou criar instância de Aplicação Outlook
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
blOutlookWasClosed = True
End If
On Error GoTo 0
'Criar instância de Aplicação Word
Set appWord = CreateObject("Word.Application")
appWord.Visible = True
With ws
rLast = .Cells(.Rows.Count, "A").End(xlUp).Row
cLast = .Cells(1, .Columns.Count).End(xlToLeft).Column
For r = 2 To rLast
Set doc = appWord.Documents.Open(Filename:="z:fupEnvio Pedido AprovadoEnvioPedidoAprovadoMarcio.docx")
For c = 1 To cLast
doc.Bookmarks(.Cells(1, c)).Range.Text = .Cells(r, c)
Next c
n = n + 1
'Criar e Enviar e-mail
Set olMI = appOutlook.CreateItem(olMailItem)
olMI.To = (.Cells(r, cEmail))
olMI.Subject = "Follow Up TKCSA"
'Range("A1:G20").Select
'Selection.Copy
'Application.CutCopyMode = False
doc.Range.Copy
olMI.Display
olMI.GetInspector.WordEditor.Range.Paste
olMI.Send
doc.Close False
Next r
End With
appWord.Quit
If blOutlookWasClosed Then appOutlook.Quit
End Sub
Postado : 09/10/2012 2:29 pm