Boa Noite Pessoal,
Estou tentando criar um código para envio de email pelo excel. Porém, não estou conseguindo resolver as inconsistências do código, poderiam ajudar por favor?
- Erros que detectei, ele informa que foi enviado o email mesmo sem enviar nenhum email.
- Next sem For... também não sei como resolver esse problema
- E em alguns testes o Loop do script falha não sei porque.
Segue abaixo o código:
Public Sub EnviarEmail()
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
'Referência à biblioteca do Outlook
Dim outapp As Outlook.Application
Dim outmail As Outlook.MailItem
Dim i As Integer, row As Integer
Dim ContactRow, LastRow, SentCounter As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Mailing")
i = 16
row = ws.Range("B" & Rows.Count).End(xlUp).row
'Convertendo "," para ";"
Range("C16:E16").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:=",", Replacement:=";", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Inicializando o Aplicativo do MS-Outlook
Set outapp = New Outlook.Application
'Do While i <= row
If ws.Range("L" & i).Value <> Empty Then GoTo NextRow
'Novo Email
Set outmail = outapp.CreateItem(olMailItem)
With outmail
.Display
.To = ws.Range("C" & i).Value
.CC = ws.Range("E" & i).Value
.BCC = ws.Range("E" & i).Value
.Subject = ws.Range("F" & i).Value
.Body = Range("C4").Value
If ws.Range("G" & i).Value <> "" Then
.Attachments.Add ws.Range("G" & i).Value
End If
If ws.Range("H" & i).Value <> "" Then
.Attachments.Add ws.Range("H" & i).Value
End If
If ws.Range("I" & i).Value <> "" Then
.Attachments.Add ws.Range("I" & i).Value
End If
If ws.Range("J" & i).Value <> "" Then
.Attachments.Add ws.Range("J" & i).Value
End If
If ws.Range("K" & i).Value <> "" Then
.Attachments.Add ws.Range("K" & i).Value
End If
.Importance = olImportanceHigh
'.Send
End With
SentCounter = SentCounter + 1
ws.Range("L" & i).Value = Now 'Set Send Date & Time
NextRow:
Next i
'Liberar Memória
Set outmail = Nothing
Set outapp = Nothing
Set ws = Nothing
Set wb = Nothing
MsgBox SentCounter & " Emails have been sent"
End Sub
Desde já muito obrigado a todos.