none
Send Mail With Outlook (Enviar Email com Outlook) RRS feed

  • Pergunta

  • 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.

    sábado, 27 de outubro de 2018 00:23