Início
![[Resolvido]Enviar e-mails de contas diferentes no Outlook Empty](https://2img.net/i/empty.gif)
cy_rangel 11/6/2020, 00:05Pessoal,
Boa-noite.
Eu tenho o seguinte código abaixo, porém observei que ele gera o e-mail pela caixa secundária, mas quando verifico em itens enviados, está na minha caixa de e-mail principal. Gostaria que o e-mail estivesse de fato nos meus itens enviados da caixa secundária.
Exemplo: caixa de e-mail (principal): cy_rangel@teste.com.br
caixa de e-mail (segundária): cy_access@teste.com.br
Acredito que isso aconteça devido ao parâmetro ".SentOnBehalfOfName".
Eu achei o código a seguir na internet, mas consegui faze-lo funcionar apenas no Excel. O código que faz isso nesse exemplo é o "Set OutAccount = OutApp.Session.Accounts.Item"
Desde já agradeço quem puder ajudar
Boa-noite.
Eu tenho o seguinte código abaixo, porém observei que ele gera o e-mail pela caixa secundária, mas quando verifico em itens enviados, está na minha caixa de e-mail principal. Gostaria que o e-mail estivesse de fato nos meus itens enviados da caixa secundária.
Exemplo: caixa de e-mail (principal): cy_rangel@teste.com.br
caixa de e-mail (segundária): cy_access@teste.com.br
Acredito que isso aconteça devido ao parâmetro ".SentOnBehalfOfName".
- Código:
Public Function fncLerArquivo(ByVal strLocalCorpoEmail As String) As String
'É NECESSÁRIO ADICIONAR ESSA FUNÇÃO NO INÍCIO ANTES DE QUALQUER CÓDIGO
Dim objfso As Object
Dim objts As Object
On Error Resume Next
Set objfso = CreateObject("Scripting.FileSystemObject")
Set objts = objfso.GetFile(strLocalCorpoEmail).OpenAsTextStream(1, -2)
fncLerArquivo = objts.readall
objts.Close
Set objfso = Nothing
End Function
Private Sub Btn_Email_Click()
Dim strLocalBoleto As String
Dim bolExisteFicheiro As Boolean
Dim strLocalCorpoEmail As String 'acrescentar essa e a variavel a seguir
Dim strBody As String
Dim objOut As Object
Dim objmail As Object
Dim objAnexo As Object
Const olMailItem = 0
Const olByValue = 1
Set objOut = CreateObject("Outlook.application")
Set objmail = objOut.CreateItem(olMailItem)
Set objAnexo = objmail.Attachments
With objmail
.SentOnBehalfOfName = Me!Conta
.To = Me("E-mail")
.Subject = Me!Assunto & " - " & Me!Cliente
'Gera o relatório em HTML para adicionar no corpo do e-mail
strBody = "Dê um nome para o seu relatório" & ".html" 'Chama a variavel nome do arquivo
strLocalCorpoEmail = CurrentProject.Path & "\Print's" & strBody 'Chama a variavel Local e concatena com o nome do arquivo
DoCmd.OpenReport "NOME DO SEU RELATÓRIO", acViewPreview, , "ID RELATORIO=" & Me!IDFORM, acHidden 'Abre o relatório no registro especifico selecionado no FORM. O 1º nome "ID RELATORIO=" é o nome do campo do seu relatório em Fonte do Controle e o 2º Me!IDFORM é nome do campo do Form (campo "Nome").
DoCmd.OutputTo acOutputReport, "NOME DO SEU RELATÓRIO", acFormatHTML, strLocalCorpoEmail
DoCmd.Close acReport, "NOME DO SEU RELATÓRIO" 'Fecha o relatório
'Add o relatório no corpo do email
.BodyFormat = olFormatHTML
.HTMLBody = "<BODY Style = Font-size:11pt;font-family:Calibri> Prezados(as),<br><br>" & fncLerArquivo(strLocalCorpoEmail)
.Save
'Anexa o BOLETO no e-mail
strLocalBoleto = CurrentProject.Path & "\Print's" & Me("Renomear Boleto") & ".pdf"
If Dir(strLocalBoleto) = "" Then
bolExisteFicheiro = True
Else
bolExisteFicheiro = False
objAnexo.Add strLocalBoleto, olByValue, 1
End If
.Display
End With
Set objAnexo = Nothing
Set objmail = Nothing
Set objOut = Nothing
If bolExisteFicheiro Then
MsgBox "O boleto não foi anexado." & vbNewLine & "Verifique o nome do arquivo ou se ele está salvo no local correspondente."
End If
End Sub
Eu achei o código a seguir na internet, mas consegui faze-lo funcionar apenas no Excel. O código que faz isso nesse exemplo é o "Set OutAccount = OutApp.Session.Accounts.Item"
- Código:
Sub CriaEmail()
'Only working in Office 2007 and higher
'Don't forget to set a reference to Outlook in the VBA editor
Dim OutApp As Outlook.Application 'objOut
Dim OutMail As Outlook.MailItem
Dim OutAccount As Outlook.Account
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
'Use the first account, see that Item is 1 now
Set OutAccount = OutApp.Session.Accounts.Item("cy_access@teste.com.br")
'Or us the name instead of the number
'Set OutAccount = OutApp.Session.Accounts("ron@something.nl")
On Error Resume Next
With OutMail
.To = WrkS.Cells(Celula.Row, 30).Value 'Coluna Para
.Subject = WrkS.Cells(Celula.Row, 31).Value 'Coluna Assunto
.Body = WrkS.Cells(Celula.Row, 32).Value 'Coluna Corpo do Email
.Importance = olImportanceHigh
.SendUsingAccount = OutAccount
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Set OutAccount = Nothing
End Sub
Desde já agradeço quem puder ajudar
Última edição por cy_rangel em 17/6/2020, 22:08, editado 2 vez(es)
