- 29 Jul 2019 às 17:11
#46165
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:
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:
Código: Selecionar todos
É possível realizar tal adaptação?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
