A Macro Abaixo esta funcionando corretamente, somente nao esta trocando a conta de Email ao qual devreia ser nesta Linha
EMail.SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
EMail.Display '.Send
Poderiam me dar uma ajuda ?
Sub A1_Envio_Individual()
'======================================
' Preparando o E-mail para ser enviado
'======================================
Dim OlApp As Outlook.Application
Dim OlMensagem As Outlook.MailItem
Dim Leitura As String
Dim contaEmail As String
Dim Loja As String
Loja = Range("A1")
Leitura = Sheets(Loja).Range("I7")
'--------------------------------------------------------------
Dim Correio As Object, EMail As Object
Dim Pasta As String
Dim Arquivo As String
Dim i As Long
Dim UltimaLinha As Long
Dim Mensagem As String
Dim Assunto As String
Sheets("Envios Individuais").Visible = True
If Range("A1").Value = "Rio de Janeiro" Or Range("A1").Value = "Academias" Or Range("A1").Value = "DVitaminas" Or Range("A1").Value = "SNC" Or Range("A1").Value = "Farmacias" Then
Range("C2:C100").Select
Selection.Copy
Sheets("Envios Individuais").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Assunto = Range("A5")
GoTo Segue
Else
Dim aba As String
aba = Range("H10").Value
Sheets(aba).Visible = True
Sheets(aba).Select
Range("C1:C100").Select
Selection.Copy
Sheets("Envios Individuais").Select
Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Assunto = Range("A5")
End If
GoTo Segue
Segue:
' Preste atencao aqui
contaEmail = ThisWorkbook.Sheets(Loja).Range("I8").Value
'Create the Outlook application and the empty email.
Set OlApp = CreateObject("Outlook.Application")
Set OlMensagem = OlApp.CreateItem(0)
'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
For w = 1 To OlApp.Session.Accounts.Count
If OlApp.Session.Accounts.Item(w).DisplayName = contaEmail Then 'Se for verdadeiro, solicita confirmação
If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & " ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
idEmail = w 'Define o id da conta para o comando enviar
Exit For 'Sai do laço
Else
Sheets(Estado).Visible = False
Sheets(Loja).Select
GoTo FIm 'Senão sai da rotina
End If
End If
Next
UltimaLinha = Sheets("Envios Individuais").Cells(Cells.Rows.Count, 2).End(xlUp).Row
If UltimaLinha < 3 Then UltimaLinha = 3
'Laço para pegar cada um dos destinatários da coluna B, começando na linha 3
For i = 3 To UltimaLinha
Set Correio = CreateObject("Outlook.Application")
Set EMail = Correio.CreateItem(0)
'Campo Assunto
EMail.Subject = Assunto '"Bonus Generator"
'Cria a mensagem que será enviada
Mensagem = " Prezado (a) " & Range("A8").Value & "," & Chr(10) & Chr(10)
Mensagem = Mensagem & " Estamos remetendo, anexo, a Tabela de Pedidos em Excel." & Chr(10) & Chr(10)
Mensagem = Mensagem & " Caso queira, me solicite um Catálogo dos Produtos em PDF ! " & Chr(10) & Chr(10)
Mensagem = Mensagem & "Atenciosamente" & Chr(10) & Chr(10)
Mensagem = Mensagem & Range("A11").Value & Chr(10)
Mensagem = Mensagem & Range("A12").Value
'A Mensagem que seguirá no corpo do e-mail
EMail.Body = Mensagem
'Para quem vai a mensagem...
EMail.To = Range("C" & i).Value
'Se for enviar com cópia
'EMail.Cc = "dantas.mariana@emrpesa.com"
'Arquivos a serem anexados
EMail.Attachments.Add Range("A2").Value & "" & Range("A15").Value
' EMail.Attachments.Add "C:UsersAndreDesktopPedidos GauerCatalogo Leader Nutrition.pdf"
'Para pré visualizar a mensagem usar Display. Para enviar direto sem visualizar, use Send
EMail.Display 'Send
EMail.ReadReceiptRequested = Leitura ' confirmação de leitura
EMail.SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
EMail.Display '.Send
Set Correio = Nothing
Set EMail = Nothing
Next
Range("C3:C110").Select
Selection.ClearContents
Sheets("Envios Individuais").Visible = False
Set OlApp = Nothing
GoTo FIm
FIm:
End Sub
Postado : 23/05/2016 12:03 pm