none
Macro envio e-mail via SMTP RRS feed

  • Pergunta

  • Olá, tudo bem? Estou com um problema em uma macro de envio para e-mails, e gostaria de vossa ajuda para solucionar.

    Meu Outlook (2010) está configurado para enviar/receber todas as pastas manualmente (ou seja, apertando F9). Eu possuo uma macro que envia e-mails à partir de um remetente secundário, ou seja, não é o meu, e queria que esses e-mails enviados pela macro não ficassem na minha caixa de saída e fossem disparados automaticamente.

    Para realizar o envio dessa forma, pensei em realizar um disparo SMTP, visto que já tenho o servidor, login e senha de disparo. Porém, preciso conseguir adaptar meu código para realizar o disparo, algo que estou tendo dificuldades.

    Segue um trecho do código atual:

    Option Explicit
    
    Dim lSalvar As String
    
    
    Sub ArquivoAnexo()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strBody As String
    
    Dim linha As String
    Dim assunto As String
    Dim destino As String
    Dim anexo As String
    Dim produto As String
    Dim unidade As String
    Dim retval As String
    Dim nome_anexo As String
    Dim validacao As String
    
    linha = 3
    
    produto = "x"
    
    Do While produto <> ""        
    
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
        produto = Sheets("Envio_Emails").Range("M" & linha)
        unidade = Sheets("Envio_Emails").Range("N" & linha)
        destino = Sheets("Envio_Emails").Range("O" & linha)
        assunto = Sheets("Envio_Emails").Range("P" & linha)
        anexo = Sheets("Envio_Emails").Range("Q" & linha)
        nome_anexo = Sheets("Envio_Emails").Range("R" & linha)
        validacao = Sheets("Envio_Emails").Range("L" & linha)
    
        Sheets("Envio_Emails").Range("S1") = produto
    
        retval = Dir(anexo)
    
        If retval = nome_anexo Then
    
        Else
            GoTo proximo_anexo
        End If
    
        If anexo = "" Then
            GoTo proximo_anexo
        End If
    
        Sheets("Envio_Emails").Select
        ActiveSheet.Calculate
    
        Select Case produto
    
            Case Is = "Automoveis"
                Sheets("PS1").Select
                Range("K3") = unidade
                ActiveSheet.Calculate
    
            Case Is = "VC"
                If validacao = "Enviar" Then
                    Sheets("PS2").Select
                    Range("K3") = unidade
                    ActiveSheet.Calculate
                Else: GoTo proximo_anexo
    
                End If
        End Select
    
        On Error Resume Next
    
        Call lCriarImagem
    
         strBody = Sheets("Envio_Emails").Range("B9") & "<img src=""" & lSalvar & """ style=""""></body>"
    
    
        With OutMail
    
        .Display
        '.From = Sheets("Envio_Emails").Range("H3")
        .SentOnBehalfOfName = "email@email.com.br"
        .To = destino
        .Subject = assunto
        .Attachments.Add anexo
        .HTMLBody = strBody & .HTMLBody
        '.Display
        .Send
    
        End With
    
        'MsgBox "Arquivo enviado com sucesso!", vbInformation
    
        On Error GoTo 0
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    
    proximo_anexo:
    
        linha = linha + 1
    
    Loop
    
    End Sub

    É possível realizar tal adaptação?

    segunda-feira, 29 de julho de 2019 20:03