Ola
olha eu aqui de novo.
A - No meu codigo abaixo, queria inserir uma assinatura , ao qual constam 3 em meu Outlock. Ja consegui por pra funcionar solicitar confirmacao de leitura. Porem a assinatura que eu tenho no Oulock, é uma Imagem. Se eu conseguir usar essa imagem, que é a minha assinatura, entao retirarei do codigo abaixo a que coloquei no corpo da mensagem.
Dai espero com isso ter uma Dim para a Assinatura
I6 = nome da assinatura a ser usada
Sub Lojas_2() ' Demais Lojas 'Setting up the Excel variables. Dim olApp As Object Dim olMailItm As Object 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 Leitura = Sheets("Brasil").Range("I5") Estado = Application.Caller Sheets(Estado).Visible = True Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A28").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole) If BuscaEstado Is Nothing Then MsgBox "Estado não localizado" GoTo Fim Else AbrevEstado = ThisWorkbook.Worksheets("Brasil").Cells(BuscaEstado.Row, 1).Value End If '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 olMailItm = olApp.CreateItem(0) 'Using the email, add multiple recipients, using a list of addresses in column C. With olMailItm 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. .BCC = SDest .Subject = "Tabela de Pedidos" '.Body = "Ola" .Body = Sheets("Mensagens").Range("R3").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("R4").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("R7").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("R9").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("R13").Value & vbCrLf & _ "" & vbCrLf & _ "Comercial: André Luiz" & vbCrLf & _ "Fone: (21)3564-2347" & vbCrLf & _ "WhatsApp: (21)98799-3381" & vbCrLf & _ "atendimento-rj@gauerdobrasil.com.br" & vbCrLf & _ "www.gauerdobrasil.com.br" & vbCrLf & _ "www.g-actionsuplementos.com.br" 'troque o diretorio do documento que queira enviar 'add' anexo. '.Attachments.Add "C:UsersAndreDesktopPedidos GauerLojista - Gauer do Brasil.xlsx" .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets("Brasil").Range("F1").Value & Sheets("Brasil").Range("I1").Value If Sheets("Brasil").Range("F2").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Brasil").Range("F2").Value & Sheets("Brasil").Range("I2").Value Else End If If Sheets("Brasil").Range("F3").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Brasil").Range("F3").Value & Sheets("Brasil").Range("I3").Value Else End If If Sheets("Brasil").Range("I4").Value = "SEND" Then .ReadReceiptRequested = Leitura ' confirmação de leitura .Send Else .ReadReceiptRequested = Leitura ' confirmação de leitura .Display End If Sheets("Brasil").Select Sheets(Estado).Visible = False End With Exit Sub Fim: 'Clean up the Outlook application. Set BuscaEstado = Nothing Set olMailItm = Nothing Set olApp = Nothing End Sub
Aqui tambem se aplicaria ao inves de resgatar uma assinatura dentro do Outlock, eu poderia fazer uma imagem em JPG dessas assinaturas e copiar as mesmas no corpo do Email, pra mim daria no mesmo. So preciso adaptar o comando abaixo sem as modificacoes anteriores acima. Esse que ta abaixo ja funciona redondo, bastando apenas inserir o caminho para introduzir uma imagem ao corpo do email.
segue o codigo que roda perfeito feito com a ajuda e participações dos parceiros MPrudencio , Mauro Coutinho e Reinaldo
Sub X_Lojas() ' Lojas da Mundo Verde 'Setting up the Excel variables. Dim olApp As Object Dim olMailItm As Object 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 Leitura = Sheets("Mundo Verde").Range("I5") Estado = Application.Caller Application.ScreenUpdating = False Sheets(Estado).Visible = True Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A29").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole) If BuscaEstado Is Nothing Then MsgBox "Estado não localizado" GoTo Fim Else AbrevEstado = ThisWorkbook.Worksheets("Mundo Verde").Cells(BuscaEstado.Row, 1).Value End If '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 olMailItm = olApp.CreateItem(0) 'Using the email, add multiple recipients, using a list of addresses in column C. With olMailItm 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. .BCC = SDest .Subject = "Tabela de Pedidos" '.Body = "Ola" .Body = Sheets("Mensagens").Range("B3").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B4").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B7").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B9").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B13").Value & vbCrLf & _ "" & vbCrLf & _ "Comercial: André Luiz" & vbCrLf & _ "Fone: (21)3564-2347" & vbCrLf & _ "WhatsApp: (21)98799-3381" & vbCrLf & _ "atendimento-rj@gauerdobrasil.com.br" & vbCrLf & _ "www.gauerdobrasil.com.br" & vbCrLf & _ "www.g-actionsuplementos.com.br" .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets("Mundo Verde").Range("F1").Value & Sheets("Mundo Verde").Range("I1").Value If Sheets("Mundo Verde").Range("F2").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Mundo Verde").Range("F2").Value & Sheets("Mundo Verde").Range("I2").Value Else End If If Sheets("Mundo Verde").Range("F3").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Mundo Verde").Range("F3").Value & Sheets("Mundo Verde").Range("I3").Value Else End If If Sheets("Mundo Verde").Range("I4").Value = "SEND" Then .ReadReceiptRequested = True ' confirmação de leitura .Send Else .ReadReceiptRequested = Leitura ' confirmação de leitura .Display End If Sheets("Mundo Verde").Select Sheets(Estado).Visible = False End With Exit Sub Fim: 'Clean up the Outlook application. Set BuscaEstado = Nothing Set olMailItm = Nothing Set olApp = Nothing End Sub
André, boa tarde!
Experimente o código (o mesmo do outro post, porém adaptado) abaixo :
Sub X_Lojas() ' Lojas da Mundo Verde '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 textoEmail As String Dim assinaturaEmail As String Dim idEmail As Integer Leitura = Sheets("Mundo Verde").Range("I5") Estado = Application.Caller Application.ScreenUpdating = False Sheets(Estado).Visible = True Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A29").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole) If BuscaEstado Is Nothing Then MsgBox "Estado não localizado" GoTo Fim Else AbrevEstado = ThisWorkbook.Worksheets("Mundo Verde").Cells(BuscaEstado.Row, 1).Value End If ' Preste atencao aqui contaEmail = ThisWorkbook.Sheets("Mundo Verde").Range("I6").Value 'Define o texto do corpo do email textoEmail = Sheets("Mensagens").Range("B3").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B4").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B7").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B9").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B13").Value & vbCrLf & _ "" & vbCrLf & _ "Comercial: André Luiz" & vbCrLf & _ "Fone: (21)3564-2347" & vbCrLf & _ "WhatsApp: (21)98799-3381" & vbCrLf & _ "atendimento-rj@gauerdobrasil.com.br" & vbCrLf & _ "www.gauerdobrasil.com.br" & vbCrLf & _ "www.g-actionsuplementos.com.br" 'Define a assinatura com base no nome da conta, informe o caminho do arquivo de imagem assinaturaEmail = "C:UsersAndreDocuments" & contaEmail & ".jpg" '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 ?", 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 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. .BCC = SDest .Subject = "Tabela de Pedidos" .HTMLBody = textoEmail & "<br><br></br>" & assinaturaEmail .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets("Mundo Verde").Range("F1").Value & Sheets("Mundo Verde").Range("I1").Value If Sheets("Mundo Verde").Range("F2").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Mundo Verde").Range("F2").Value & Sheets("Mundo Verde").Range("I2").Value Else End If If Sheets("Mundo Verde").Range("F3").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Mundo Verde").Range("F3").Value & Sheets("Mundo Verde").Range("I3").Value Else End If If Sheets("Mundo Verde").Range("I4").Value = "SEND" Then .ReadReceiptRequested = True ' confirmação de leitura .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail) .Send Else .ReadReceiptRequested = Leitura ' confirmação de leitura .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail) .Send End If Sheets("Mundo Verde").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
Abs
Espero ter ajudado.
Abs.
Saulo Robles
André,
Faça uma pequena alteração na seguinte linha para o que segue:
.HTMLBody = textoEmail & "<br><br></br> & "<img src =" & assinaturaEmail & ">"
Esqueci de adicionar a TAG para inserir imagem <img src => no código.
Desculpa ae e Abs
Espero ter ajudado.
Abs.
Saulo Robles
Ola amigao , tem que desculpar nada não, vcs aqui do forum ajudam muito e muito mesmo !
Farei o seguinte, amanha te envio o novo codigo, aquele que vc me passou mais cedo, que ficou joia e tive que fazer algumas adaptacoes, e amanha eu posto o codigo todo que ja esta testado, e entao te peco que vc acrescente a modificacao de poder inserir a assinatura e também poder inserir imagens ao qual os caminhos estejam em celulas I7, I8 , I9 e i10. Porem tem um detalhe, se as celulas i7 a i10 estiverem vazias, que não de o erro e ignore. Conforme eu fiz no comando acima dos trs attachments. Amanha entao lhe envio o codigo completo ok amigao ?
Por hora somente meu muito obrigado.
André,
Ok meu amigo. Aguardo retorno amanhã.
Abs
Espero ter ajudado.
Abs.
Saulo Robles
Boa noite, fazerbem.
Não cheguei olhar seu código mas creio que essa explicação ajudara em algo:
http://www.rondebruin.nl/win/s1/outlook/signature.htm
Se a resposta foi útil! Clique na mãozinha ao lado do botão Citar.
Sua dúvida foi respondida? Marque como RESOLVIDO em seus tópicos, usando o botão com marca verde.
Ola SroBles e Trindade.
Segue meu codigo com as modificacoes feitas, Testei aqui e agora sim esta chupeta !
Sub X_Lojas() '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 strbody = "<H3><B>Olá caro Lojista !</B></H3>" & _ Sheets("Mensagens").Range("B3").Value & _ "<br><br>" & _ Sheets("Mensagens").Range("B4").Value & _ "<br><br>" & _ Sheets("Mensagens").Range("B7").Value & _ "<br><br>" & _ Sheets("Mensagens").Range("B9").Value & _ "<br><br>" & _ Sheets("Mensagens").Range("B13").Value & _ "<br><br><B>Obrigado !!</B>" Leitura = Sheets("Mundo Verde").Range("I5") Estado = Application.Caller Application.ScreenUpdating = False Sheets(Estado).Visible = True Set BuscaEstado = ThisWorkbook.ActiveSheet.Range("A3:A29").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole) If BuscaEstado Is Nothing Then MsgBox "Estado não localizado" GoTo Fim Else AbrevEstado = ThisWorkbook.Worksheets("Mundo Verde").Cells(BuscaEstado.Row, 1).Value End If ' Preste atencao aqui contaEmail = ThisWorkbook.Sheets("Mundo Verde").Range("I6").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 ?", 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 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 = "Tabela de Pedidos" ' .Body = Sheets("Mensagens").Range("B3").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B4").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B7").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B9").Value & vbCrLf & _ "" & vbCrLf & _ Sheets("Mensagens").Range("B13").Value & vbCrLf & _ "" & vbCrLf & _ "Comercial: André Luiz" & vbCrLf & _ "Fone: (21)3564-2347" & vbCrLf & _ "WhatsApp: (21)98799-3381" & vbCrLf & _ "atendimento-rj@gauerdobrasil.com.br" & vbCrLf & _ "www.gauerdobrasil.com.br" & vbCrLf & _ "www.g-actionsuplementos.com.br" .HTMLBody = strbody & "<br>" & .HTMLBody .Attachments.Add "C:UsersAndreDesktopPedidos Gauer" & Sheets("Mundo Verde").Range("F1").Value & Sheets("Mundo Verde").Range("I1").Value If Sheets("Mundo Verde").Range("F2").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Mundo Verde").Range("F2").Value & Sheets("Mundo Verde").Range("I2").Value Else End If If Sheets("Mundo Verde").Range("F3").Value > 0 Then .Attachments.Add "C:UsersAndreDesktopPedidos GauerBanner" & Sheets("Mundo Verde").Range("F3").Value & Sheets("Mundo Verde").Range("I3").Value Else End If If Sheets("Mundo Verde").Range("I4").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("Mundo Verde").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
Grato mais uma vez a todos !!
Andre
André,
Isso aí cara!!!
Que bom que correu como desejado!
Abs
Espero ter ajudado.
Abs.
Saulo Robles
André,
Faça uma pequena alteração na seguinte linha para o que segue:
.HTMLBody = textoEmail & "<br><br></br> & "<img src =" & assinaturaEmail & ">"
Esqueci de adicionar a TAG para inserir imagem <img src => no código.
Desculpa ae e Abs
Ola Amigo, achei melhor tentar sua dica, mas acontece que a linha abaixo nao funcionou
.HTMLBody = strbody & "<br><br></br>" & "<img src =" & assinaturaEmail & ">"
Segue todo o meu codigo pra ver se errei em algo.
Coloquei a imagem da assinatura com nome : Amigo Lojista.JPG , outra com Vendas Gauer.JPG
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") Dim assinaturaEmail As String If Sheets(Loja).Range("K4").Value = "" Then MsgBox ("Qual Empresa associar esta Mensagem 1-Gauer do Brasil ou 2-Leader Nutrition ?") Range("K4").Select GoTo Fim Else End If If Sheets(Loja).Range("Q4").Value = "" Then MsgBox ("A conta de E-mail não foi associada !") GoTo Fim Else End If If Sheets(Loja).Range("F7").Value = 1 Then strbody = "<H2>" & _ Sheets(Loja).Range("AD2").Value & _ "</H2>" & _ "<H3 style='color: #870c0c'>" & _ Sheets(Loja).Range("AD6").Value & _ "</H3>" & _ "<H3>" & _ Sheets(Loja).Range("AD10").Value & _ "<br><br>" & _ Sheets(Loja).Range("AD14").Value & _ "<br><br>" & _ Sheets(Loja).Range("AD18").Value & _ "<br><br>" GoTo Continuar Else If Sheets(Loja).Range("K4").Value = 1 Then strbody = "<H2>" & _ Sheets(Loja).Range("V2").Value & _ "</H2>" & _ "<H3 style='color: #870c0c'>" & _ Sheets(Loja).Range("V6").Value & _ "</H3>" & _ "<H3>" & _ Sheets(Loja).Range("V10").Value & _ "<br><br>" & _ Sheets(Loja).Range("V14").Value & _ "<br><br>" & _ Sheets(Loja).Range("V18").Value & _ "<br><br>" & _ Sheets(Loja).Range("V22").Value & _ "<br><br>" Else strbody = "<H2>" & _ Sheets(Loja).Range("Z2").Value & _ "</H2>" & _ "<H3 style='color: #870c0c'>" & _ Sheets(Loja).Range("Z6").Value & _ "</H3>" & _ "<H3>" & _ Sheets(Loja).Range("Z10").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z14").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z18").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z22").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z23").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z24").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z25").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z26").Value & _ "<br><br>" End If End If GoTo Continuar Continuar: Leitura = Sheets(Loja).Range("I7") If Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Pular2 Else End If Estado = Application.Caller Application.ScreenUpdating = False Sheets(Estado).Visible = True GoTo Pular2 Pular2: Application.DisplayAlerts = False 'desabilite o alerta '------------------------------------------------------------ 'DVitaminas/SNC/...... If Sheets(Loja).Range("E15").Value = 1 Then GoTo Pular Else End If '----------------------------------------------------------- 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 GoTo Pular Pular: ' Preste atencao aqui contaEmail = ThisWorkbook.Sheets(Loja).Range("I8").Value If Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Pular3 Else End If '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 GoTo Pular3 Pular3: If Sheets(Loja).Range("A1").Value = "DVitaminas" Then iCounter = 2 GoTo Proximo1 Else End If iCounter = 1 GoTo Proximo1 Proximo1: '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 Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Proximo Else End If If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & " ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then GoTo Proximo Proximo: 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 If Sheets(Loja).Range("A1").Value = "DVitaminas" Then For iCounter = 2 To WorksheetFunction.CountA(Columns(3)) ' Sheets("Email").Select SDest = SDest & ";" & Cells(iCounter, 3).Value Next iCounter GoTo Proximo2 Else End If For iCounter = 1 To WorksheetFunction.CountA(Columns(3)) ' Sheets("Email").Select SDest = SDest & ";" & Cells(iCounter, 3).Value Next iCounter GoTo Proximo2 Proximo2: '------------------------------------------------------------- 'Define a assinatura com base no nome da conta, informe o caminho do arquivo de imagem assinaturaEmail = "C:UsersAndreDesktopPedidos Gauer" ' & contaEmail & ".jpg" '--------------------------------------------------------------- '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><br></br>" & "<img src =" & assinaturaEmail & ">" ' & "<br>" & "<br><br></br>" & assinaturaEmail ' & .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 If Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Pular4 Else End If Sheets(Estado).Visible = False GoTo Pular4 Pular4: GoTo Fim End With Exit Sub Fim: 'Clean up the Outlook application. Set BuscaEstado = Nothing Set OlMensagem = Nothing Set OlApp = Nothing End Sub
fiz uma modificacao mas esbareei numa linha contendo erro, alguem pode me ajudar ?
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
Option Explicit Dim assinatura As Variant Public Function pega_assinatura(ByVal sFile As String) As String Dim fso As Object Dim ts As Object Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) pega_assinatura = ts.ReadAll ts.Close End Function 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") ' Dim assinaturaEmail As String assinatura = pega_assinatura("C:Documents and Settings" & Environ("username") & "Application DataMicrosoftSignaturesSem título.htm") If Sheets(Loja).Range("K4").Value = "" Then MsgBox ("Qual Empresa associar esta Mensagem 1-Gauer do Brasil ou 2-Leader Nutrition ?") Range("K4").Select GoTo Fim Else End If If Sheets(Loja).Range("Q4").Value = "" Then MsgBox ("A conta de E-mail não foi associada !") GoTo Fim Else End If If Sheets(Loja).Range("F7").Value = 1 Then strbody = "<H2>" & _ Sheets(Loja).Range("AD2").Value & _ "</H2>" & _ "<H3 style='color: #870c0c'>" & _ Sheets(Loja).Range("AD6").Value & _ "</H3>" & _ "<H3>" & _ Sheets(Loja).Range("AD10").Value & _ "<br><br>" & _ Sheets(Loja).Range("AD14").Value & _ "<br><br>" & _ Sheets(Loja).Range("AD18").Value & _ "<br><br>" GoTo Continuar Else If Sheets(Loja).Range("K4").Value = 1 Then strbody = "<H2>" & _ Sheets(Loja).Range("V2").Value & _ "</H2>" & _ "<H3 style='color: #870c0c'>" & _ Sheets(Loja).Range("V6").Value & _ "</H3>" & _ "<H3>" & _ Sheets(Loja).Range("V10").Value & _ "<br><br>" & _ Sheets(Loja).Range("V14").Value & _ "<br><br>" & _ Sheets(Loja).Range("V18").Value & _ "<br><br>" & _ Sheets(Loja).Range("V22").Value & _ "<br><br>" & assinatura & "</body></html>" Else strbody = "<H2>" & _ Sheets(Loja).Range("Z2").Value & _ "</H2>" & _ "<H3 style='color: #870c0c'>" & _ Sheets(Loja).Range("Z6").Value & _ "</H3>" & _ "<H3>" & _ Sheets(Loja).Range("Z10").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z14").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z18").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z22").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z23").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z24").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z25").Value & _ "<br><br>" & _ Sheets(Loja).Range("Z26").Value & _ "<br><br>" End If End If GoTo Continuar Continuar: Leitura = Sheets(Loja).Range("I7") If Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Pular2 Else End If Estado = Application.Caller Application.ScreenUpdating = False Sheets(Estado).Visible = True GoTo Pular2 Pular2: Application.DisplayAlerts = False 'desabilite o alerta '------------------------------------------------------------ 'DVitaminas/SNC/...... If Sheets(Loja).Range("E15").Value = 1 Then GoTo Pular Else End If '----------------------------------------------------------- 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 GoTo Pular Pular: ' Preste atencao aqui contaEmail = ThisWorkbook.Sheets(Loja).Range("I8").Value If Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Pular3 Else End If '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 GoTo Pular3 Pular3: If Sheets(Loja).Range("A1").Value = "DVitaminas" Then iCounter = 2 GoTo Proximo1 Else End If iCounter = 1 GoTo Proximo1 Proximo1: '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 Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Proximo Else End If If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & " ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then GoTo Proximo Proximo: 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 If Sheets(Loja).Range("A1").Value = "DVitaminas" Then For iCounter = 2 To WorksheetFunction.CountA(Columns(3)) ' Sheets("Email").Select SDest = SDest & ";" & Cells(iCounter, 3).Value Next iCounter GoTo Proximo2 Else End If For iCounter = 1 To WorksheetFunction.CountA(Columns(3)) ' Sheets("Email").Select SDest = SDest & ";" & Cells(iCounter, 3).Value Next iCounter GoTo Proximo2 Proximo2: '------------------------------------------------------------- 'Define a assinatura com base no nome da conta, informe o caminho do arquivo de imagem ' assinaturaEmail = "C:UsersAndreDesktopPedidos Gauer" ' & contaEmail & ".jpg" '--------------------------------------------------------------- '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><br></br>" & "<img src =" & assinaturaEmail & ">" ' & "<br>" & "<br><br></br>" & assinaturaEmail ' & .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 If Sheets(Loja).Range("A1").Value = "DVitaminas" Then GoTo Pular4 Else End If Sheets(Estado).Visible = False GoTo Pular4 Pular4: GoTo Fim End With Exit Sub Fim: 'Clean up the Outlook application. Set BuscaEstado = Nothing Set OlMensagem = Nothing Set OlApp = Nothing End Sub
André, boa noite!
Desculpe a demora na resposta!
Vamos lá.
Antes de começar a alterar diretamente suas macros e planilhas, gostaria de pedir que testasse o arquivo em anexo.
Ele funciona da seguinte maneira :
1 - Crie uma pasta em C: com o nome de Assinaturas;
2 - Nesta pasta, coloque os arquivos .html e, um outro arquivo .JPG de mesmo nome. Isso se faz necessário pois, li em muitos fóruns que se existir apenas o arquivo .html da assinatura, não existe uma maneira para forçar a carga da imagem.
3 - Ao enviar o e-mail, o funcionamento é basicamente o mesmo do seu projeto, só o que foi adicionado foi a informação do caminho da imagem de assinatura e, para que isso funcione corretamente, a janela contendo a mensagem deve ser exibida, caso contrário, o e-mail será enviado, porém com erros.
Teste o modelo e retorne ok?
Caso funcione conforme esperado, aí partimos para a edição da sua macro.
Abs
Espero ter ajudado.
Abs.
Saulo Robles
Oi , eu esperava ago mais simples como o que vc havia sugerido antes, porem tb nao deu certo.
André,
Faça uma pequena alteração na seguinte linha para o que segue:
.HTMLBody = textoEmail & "<br><br></br> & "<img src =" & assinaturaEmail & ">"
Esqueci de adicionar a TAG para inserir imagem <img src => no código.
Desculpa ae e Abs
Finalmente depois de tanto procurar uma solucao a este problema aqui no forum e na net, achei um site que consegui resolver, e dai vou deixar aqui postado para quem sabe possa ajudar alguem.
este codico tem que ficar exatamente desta forma.
Option Explicit
Dim assinatura As Variant
Public Function pega_assinatura(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
pega_assinatura = ts.ReadAll
ts.Close
End Function
---------------------------------------------------------------------- depois disto inicia o restante
Sub X_Lojas()
' Lojas Gerais
'Setting up the Excel variables.
Dim olapp As Outlook.Application
Dim OlMensagem As Outlook.MailItem ...........................
acrescentar mais abaixo o seguinte
'--------------------------------------------------------
Dim objMail As MailItem
Set olapp = Outlook.Application
'Create mail item
Set objMail = olapp.CreateItem(olMailItem)
'------------------------------------------------------------
e mais abaixo o restante
.Subject = Assunto '"Tabela de Pedidos"
'----------------------------------------------------
.BodyFormat = olFormatHTML
'----------------------------------------------------
.HTMLBody = strbody & assinatura & .HTMLBody
Abraços