Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Macro usar uma das ...
 
Notifications
Clear all

Macro usar uma das minhas assinaturas

 
2024 - VBA & Macros
Post Recente por fazerbem 9 anos atrás
14 Posts
3 Usuários
0 Reactions
1,912 Visualizações
RSS
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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
 
Postado : 02/01/2016 8:43 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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
 
Postado : 03/01/2016 9:55 am
 srobles
(@srobles)
Posts: 231
Estimable Member
 

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

 
Postado : 05/01/2016 3:52 pm
 srobles
(@srobles)
Posts: 231
Estimable Member
 

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

 
Postado : 05/01/2016 4:01 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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.

 
Postado : 05/01/2016 5:22 pm
 srobles
(@srobles)
Posts: 231
Estimable Member
 

André,

Ok meu amigo. Aguardo retorno amanhã.

Abs

Espero ter ajudado.

Abs.

Saulo Robles

 
Postado : 05/01/2016 6:59 pm
Trindade
 Trindade
(@trindade)
Posts: 278
Reputable Member
 

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.

 
Postado : 05/01/2016 9:40 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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

 
Postado : 06/01/2016 2:21 pm
 srobles
(@srobles)
Posts: 231
Estimable Member
 

André,

Isso aí cara!!!

Que bom que correu como desejado!

Abs

Espero ter ajudado.

Abs.

Saulo Robles

 
Postado : 06/01/2016 4:34 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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
 
Postado : 25/03/2016 5:16 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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
 
Postado : 28/03/2016 9:14 am
 srobles
(@srobles)
Posts: 231
Estimable Member
 

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

 
Postado : 28/03/2016 5:49 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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

 
Postado : 29/03/2016 12:37 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

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

 
Postado : 16/04/2016 6:02 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico