Minha Macro ja esta fazendo o passo 1 do topico. A tela pisca e tudo mais, pega a assinatura com imagem etc .
So tem um problema, eu tenho 4 tipos de assinatura que uso , pois trabalho com vendas, Dai a MAcro abaixo esta escolhendo de forma certa qual conta inclusive será usada no envio da mensagem, porem a assinatura esta sendo pega aquela que esta na escolha da assinatura padrao para novas mensagens, dentro da tela do outloock, assinaturas e papel de carta.
Se eu trocar manuqlmente em novas mensagens a assinatura, dai funciona, mas quero fazer isso atraves da Macro assim como foi feita na escolha de qual conta sera usada no envio do email.
Acho que agora expliquei da forma certa meu problema aqui.
Alguns dos amigos poderia me ajudar adaptando isso ao codigo abaixo ?
Andre Luiz
Sub X_Lojas()
' Lojas Gerais
'Setting up the Excel variables.
Dim OlApp As Outlook.Application
Dim OlMensagem As Outlook.MailItem
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim Estado As String
Dim BuscaEstado As Range
Dim AbrevEstado As String
Dim Leitura As String
Dim contaEmail As String
Dim idEmail As Integer
Dim strbody As String
Dim Loja As String
Loja = Range("A1")
Dim Assunto As String
Assunto = Range("L1")
strbody = "<H2>" & _
Sheets("Mensagens").Range("B3").Value & _
"</H2>" & _
"<H3 style='color: #870c0c'>" & _
Sheets("Mensagens").Range("B4").Value & _
"</H3>" & _
"<H3>" & _
Sheets("Mensagens").Range("B5").Value & _
"<br><br>" & _
Sheets("Mensagens").Range("B6").Value & _
"<br><br>" & _
Sheets("Mensagens").Range("B7").Value & _
"<br><br>" & _
Sheets("Mensagens").Range("B8").Value & _
"<br><br>" & _
Sheets("Mensagens").Range("B9").Value & _
"<br><br>" & _
Sheets("Mensagens").Range("B10").Value & _
"<br><br>" & _
Sheets("Mensagens").Range("B11").Value & _
"<br><br>" & _
Sheets("Mensagens").Range("B12").Value & _
"</H3>" & _
"<br><br><B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & _
"<br><br>"
Leitura = Sheets(Loja).Range("I7")
Estado = Application.Caller
Application.ScreenUpdating = False
Sheets(Estado).Visible = True
Application.DisplayAlerts = False 'desabilite o alerta
Range("L2").Select
Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A30").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)
If BuscaEstado Is Nothing Then
MsgBox "Estado não localizado"
GoTo Fim
Else
AbrevEstado = ThisWorkbook.Worksheets(Loja).Cells(BuscaEstado.Row, 1).Value
End If
' Preste atencao aqui
contaEmail = ThisWorkbook.Sheets(Loja).Range("I8").Value
'Quero que aqui, ao inves de ter RJ tenha a variavel Estado que vai estar associado ao click na regiao do mapa.
ThisWorkbook.Worksheets(AbrevEstado).Select
iCounter = 1
'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
'-------------------------------------------------------------------------------
'Using the email, add multiple recipients, using a list of addresses in column C.
With OlMensagem
For iCounter = 1 To WorksheetFunction.CountA(Columns(3))
' Sheets("Email").Select
SDest = SDest & ";" & Cells(iCounter, 3).Value
Next iCounter
'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
.Display
.BCC = SDest
.Subject = Assunto '"Tabela de Pedidos"
.HTMLBody = strbody & "<br>" & .HTMLBody
If Sheets(Loja).Range("F1").Value > 0 Then
.Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F1").Value & Sheets(Loja).Range("I1").Value
Else
End If
If Sheets(Loja).Range("F2").Value > 0 Then
.Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets(Loja).Range("F2").Value & Sheets(Loja).Range("I2").Value
Else
End If
If Sheets(Loja).Range("F3").Value > 0 Then
.Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets(Loja).Range("F3").Value & Sheets(Loja).Range("I3").Value
Else
End If
If Sheets(Loja).Range("F4").Value > 0 Then
.Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets(Loja).Range("F4").Value & Sheets(Loja).Range("I4").Value
Else
End If
If Sheets(Loja).Range("I6").Value = "SEND" Then
.ReadReceiptRequested = Leitura ' confirmação de leitura
.SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
.Send
Else
.ReadReceiptRequested = Leitura ' confirmação de leitura
.SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
.Display
End If
Sheets(Loja).Select
Sheets(Estado).Visible = False
GoTo Fim
End With
Exit Sub
Fim:
'Clean up the Outlook application.
Set BuscaEstado = Nothing
Set OlMensagem = Nothing
Set OlApp = Nothing
End Sub
Postado : 22/03/2016 1:25 pm