- 29 Out 2015 às 15:32
#4806
Boa tarde!
Estou utilizando a macro abaixo para enviar e-mail, porém estou com dificuldade para o endereço a enviar com cópia (CC) a macro funciona normalmente, mas não consigo inserir o endereço de e-mail que está localizado na coluna "R" da minha planilha, para enviar com cópia.
_____________________________
Sub Enviar_EMail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo limpa
For Each cell In Columns("Q").Cells.SpecialCells(xlCellTypeConstants)
'verifica se o email é valido e se a coluna esta preenchida com Avisar
If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "O").Value) = "avisar" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = Plan.Cells(Line, 18)
.Subject = "Controle de Contratos"
.Body = "Prezado!" & vbCrLf & vbCrLf & _
"Segue contrato próximo ao vencimento ou vencido." & vbCrLf & vbCrLf & _
"Fornecedor: " & Cells(cell.Row, "C") & vbCrLf & _
"CNPJ: " & Cells(cell.Row, "D") & vbCrLf & _
"Objetivo do Contrato: " & Cells(cell.Row, "E") & vbCrLf & _
"Filial: " & Cells(cell.Row, "H") & vbCrLf & _
"Período de Vigência: " & Cells(cell.Row, "K") & " até " & Cells(cell.Row, "M") & vbCrLf & vbCrLf & _
"*Favor encaminhar para o responsável, caso essa categoria/filial não esteja mais na sua responsabilidade e nos avisar para corrigirmos no controle." & vbCrLf & vbCrLf & _
"Grato," & vbCrLf & vbCrLf & _
"CCM"
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
limpa:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Estou utilizando a macro abaixo para enviar e-mail, porém estou com dificuldade para o endereço a enviar com cópia (CC) a macro funciona normalmente, mas não consigo inserir o endereço de e-mail que está localizado na coluna "R" da minha planilha, para enviar com cópia.
_____________________________
Sub Enviar_EMail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo limpa
For Each cell In Columns("Q").Cells.SpecialCells(xlCellTypeConstants)
'verifica se o email é valido e se a coluna esta preenchida com Avisar
If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "O").Value) = "avisar" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = Plan.Cells(Line, 18)
.Subject = "Controle de Contratos"
.Body = "Prezado!" & vbCrLf & vbCrLf & _
"Segue contrato próximo ao vencimento ou vencido." & vbCrLf & vbCrLf & _
"Fornecedor: " & Cells(cell.Row, "C") & vbCrLf & _
"CNPJ: " & Cells(cell.Row, "D") & vbCrLf & _
"Objetivo do Contrato: " & Cells(cell.Row, "E") & vbCrLf & _
"Filial: " & Cells(cell.Row, "H") & vbCrLf & _
"Período de Vigência: " & Cells(cell.Row, "K") & " até " & Cells(cell.Row, "M") & vbCrLf & vbCrLf & _
"*Favor encaminhar para o responsável, caso essa categoria/filial não esteja mais na sua responsabilidade e nos avisar para corrigirmos no controle." & vbCrLf & vbCrLf & _
"Grato," & vbCrLf & vbCrLf & _
"CCM"
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
limpa:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
