Ir para conteúdo

POWERED BY:

Arquivado

Este tópico foi arquivado e está fechado para novas respostas.

GTTJ

[Resolvido] Pegar Assinatura do Outlook

Por , em Algoritmos & Outras Tecnologias

Recommended Posts

GTTJ    0

GTTJ
Postado

rezados,

 

Boa noite,

 

Tenho uma macro que pega informações de uma Sheet e coloca no corpo do e-mail.

 

O Que eu quero é que além de pegar esta informação é que coloque a minha assinatura configurada no meu Outlook, ao invés de colocar uma assinatura sem formatação, como texto. Alguém pode me ajudar?

 

Desde já agradeço à atenção, :joia:

Compartilhar este post

Link para o post
Compartilhar em outros sites

GTTJ    0

GTTJ
Postado

Prezados,

 

Bom dia,

 

Segue a solução:

 

Tenho a seguinte macro

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 Envio_Email()

On Error Resume Next
Dim myOlApp As Outlook.Application
Dim myItem As MailItem
Dim myAttachments As Attachments
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments

 'Esta função está sendo considerada para o Windows NT, caso for o Windows XP o caminho para o arquivo de assinatura é C:\Documents and Settings\" & (Environ"username") & "\Dados de Aplicativos\Microsoft\Signatures\Sem título.htm")


  assinatura = pega_assinatura("C:\Documents and Settings\" & Environ
("username") & "\Application Data\Microsoft\Signatures\Sem título.htm")

With myItem

   .To = Sheets("E-MAIL").Range("h4").Value '"usuario@dominio.com.br"
   .Cc = Sheets("E-MAIL").Range("h11").Value '"usuario@dominio.com.br"
   .Subject = "Relatório de Aderência Atualizado até " & Sheets("E-MAIL").Range("H9").Value

 'Além de colocar todo o conteúdo em formato HTML estas linhas pegam a assinatura na minha máquina.

   .HTMLBody = "<html><body>" & Sheets("E-MAIL").Range("H17").Value & "<P>" & Sheets("E-

MAIL").Range("H19").Value & _
   "<P>" & Sheets("E-MAIL").Range("H21").Value & "<P>" & Sheets("E-MAIL").Range

("H23").Value & _
   "<P>" & Sheets("E-MAIL").Range("H25").Value & assinatura & "</body></html>"

   myItem.SentOnBehalfOfName = Sheets("E-MAIL").Range("h2").Value
   myAttachments.Add Range("L1").Value

   .Display

   SendKeys ("%r"), True

End With

Windows("MATRIZ DE ADERÊNCIA.xls").Activate

End Sub

Observações:

 

1º Este código além de capturar a assinatura que você tenha cadastrado no Outlook ela preenche os Campos "De", "Para", "Cc", "Assunto" e "Anexo";

 

2º O Comando SendKeys ("%r"), True evita a maldita mensagem de segurança do Outlook 2003;

 

3º Para que este código funcione é necessário referenciar a biblioteca do Outlook 2003, ou seja, Ferramentas\Referências no editor de VBA e marcar a opção Microsoft Office Outlook 11.0 Object Library.

 

Desde já agradeço à atenção de todos :clap:

Compartilhar este post

Link para o post
Compartilhar em outros sites

quitZAUMMM    18

quitZAUMMM
Postado

Obrigado por compartilhar a solução :thumbsup:

 

[]s

Compartilhar este post

Link para o post
Compartilhar em outros sites
Ir para a lista de tópicos Algoritmos & Outras Tecnologias
×

Informação importante

Ao usar o fórum, você concorda com nossos Termos e condições.

  Aceito