Bedin,

Não deu tempo testar, mas achei uma dica que é a seguinte.

Ola sds,

Você tem que ler do registro do windows, uma chave "Default signature" que esta dentro da pasta signatures em HKEY_CURRENT_USERIdentities.Faça uma busca no registro que você encontra.

Att,

Fagner

Fonte: http://vbweb.com.br/forum_resp.asp?Forum=VB&Codigo=221876

Assim que der eu crio uma rotina pra testar.
Se vc consegui, por favor nos conte

Olá adelsonrms!

Tentei mas não consegui... como posso fazer a leitura daquela chave de registro?

Agradeço pelas informações se puder me ajudar eu agradeço!

Abraço!

Galera!

Se alguém puder me ajudar neste caso, eu agradeço!

Olá Pessoal!

Alguém tem alguma idéia de como fazer para inserir a assinatura conforme expliquei?

Estou insistindo na pergunta, porque pesquisei muito e vejo que esta é uma dúvida de muitas pessoas.

Se alguém puder me ajudar eu agradeço!

Abraço!

Olá Bedin, td bem
Desculpe a demora, estava ausente esses dias
Bom, crie uma pequena aplicação que demostra como capturar a assinatura
Para teste, crie um Módulo de Classe
Para usar a classe, utilize o código 2 em um userform por exemplo

Segue nas proximas mensagens o código completo da aplicação

Private oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Private m_objAppInst As Outlook.Application
Private m_sPathAssinaturas As String
Private m_sAppDataDir As String
Private m_sNomeAssinatura As String
Private m_sFullPathAss As String
Private m_sContentMailBody As String

Private Sub Class_Initialize()
    InstanciaOutlook
End Sub

Private Sub Class_Terminate()
    Set m_objAppInst = Nothing
End Sub

Sub InstanciaOutlook()
    On Error Resume Next
    LoadVars
    Set oApp = GetObject(, "Outlook.Application")
    If oApp Is Nothing Then
        Set oApp = New Outlook.Application
    End If
    Set AppInst = oApp
    ListaAssinaturas
End Sub

Sub GeraEmail()
'Defini o diretório onde estão armazenadas as assinaturas
    FullPathAss = PathAssinaturas + Me.NomeAssinatura & ".htm"
    Me.ContentMailBody = getMailBody
    
    If Me.ContentMailBody <> "" Then
        Set oMail = AppInst.CreateItem(olMailItem)
        oMail.HTMLBody = Me.ContentMailBody & vbNewLine & vbNewLine & GetAssinatura("pessoal")
        oMail.Display
    End If
End Sub

Private Function getMailBody() As String
    Dim sCheck As String
    On Error Resume Next
    sCheck = Dir(Me.ContentMailBody)
    If sCheck <> "" Then
        getMailBody = getHTMLFromFilename(Me.ContentMailBody)
    Else
        getMailBody = Me.ContentMailBody
    End If
End Function

Private Sub LoadVars()
    Dim oShell As Object
    'Instancia o motor de script
    Set oShell = CreateObject("WScript.Shell")
    'Recebe o diretório padrão de dados do perfil do usuário
    AppDataDir = oShell.SpecialFolders("AppData")
    PathAssinaturas = AppDataDir + "MicrosoftAssinaturas"    
End Sub

Private Function getHTMLFromFilename(sFileName As String)

 'Constante de leitura de arquivos
    Const ForReading = 1, ForWriting = 2
    'Instancia o Fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    'Abre o arquivo da assinatura somente leitura
    Set f = fso.OpenTextFile(sFileName, ForReading)
    'Recupera o seu conteudo (HTML)
    getHTMLFromFilename = f.ReadAll
    'Fecha, não precisamos mais dele
    f.Close

End Function

Continua o código da classe

Function GetAssinatura(sNomeAssinatura As String) As String
    
    Dim sAppDataDir As String
    Dim strSignaturePath As String, strHTML As String
    'Objetos de manipulação de arquivos
    Dim fso As Object, f As Object

    On Error GoTo ErrHandler
    'Recebe o nome do arquivo HTML que representa a assinatura
    strHTML = getHTMLFromFilename(FullPathAss)
    'Recebi o conteudo da assinatura a partir da variavel
   GetAssinatura = strHTML
   
    GoTo ExitHandler
ErrHandler:
    MsgBox Err.Description, vbCritical, "GetOutlookSignature"
ExitHandler:
    Set oShell = Nothing
    Set fso = Nothing
    Set f = Nothing
End Function

Segue abaixo mais um trexo do código....

Function ListaAssinaturas() As Collection
    Dim flAss As Scripting.File
    Dim fdAss As Scripting.Folder
    Dim fso As Scripting.FileSystemObject
    
    On Error GoTo ListaAssinaturas_Err

    'Inicializa a coleção
    Set ListaAssinaturas = New Collection
    'Instancia o Fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    'Retorna o objeto da pasta de assinaturas
    Set fdAss = fso.GetFolder(PathAssinaturas)
    
    'Verifica se existe arquivos
    If fdAss.Files.Count > 0 Then
        'Navega entre os arquivos
        For Each flAss In fdAss.Files
            'Se for um arquivo htm...
            If LCase(fso.GetExtensionName(flAss.Path)) = "htm" Then
                'Adicion na coleção
                ListaAssinaturas.Add fso.GetBaseName(flAss.Path), flAss.Name
            End If
        Next
    End If

    'Finaliza a rotina
    On Error GoTo 0
    Exit Function

    'Trata a ocorrencia de erros não previsíveis
ListaAssinaturas_Err:
    If Err <> 0 Then
        If MsgBox("Erro não tratado ao executar uma ação no procedimento.", vbCritical + vbYesNo, "Erro do Sistema") = vbYes Then
            Stop
            Resume
        End If
    End If
        
End Function

Propriedades...

Private Property Get AppInst() As Outlook.Application
    Set AppInst = m_objAppInst
End Property

Private Property Set AppInst(objAppInst As Outlook.Application)
    Set m_objAppInst = objAppInst
End Property

Private Property Get PathAssinaturas() As String
    PathAssinaturas = m_sPathAssinaturas
End Property

Private Property Let PathAssinaturas(ByVal sPathAssinaturas As String)
    m_sPathAssinaturas = sPathAssinaturas
End Property

Public Property Get AppDataDir() As String
    AppDataDir = m_sAppDataDir
End Property

Public Property Let AppDataDir(ByVal sAppDataDir As String)
    m_sAppDataDir = sAppDataDir
End Property

Public Property Get NomeAssinatura() As String
    NomeAssinatura = m_sNomeAssinatura
End Property

Public Property Let NomeAssinatura(ByVal sNomeAssinatura As String)
    m_sNomeAssinatura = sNomeAssinatura
End Property

Private Property Get FullPathAss() As String
    FullPathAss = m_sFullPathAss
End Property

Private Property Let FullPathAss(ByVal sFullPathAss As String)
    m_sFullPathAss = sFullPathAss
End Property

Public Property Get ContentMailBody() As String
    ContentMailBody = m_sContentMailBody
End Property

Public Property Let ContentMailBody(ByVal sContentMailBody As String)
    m_sContentMailBody = sContentMailBody
End Property

Código 2 - Uso da classe

  Assinatura.NomeAssinatura = ListBox1.List(ListBox1.ListIndex)
    If optConteudo Then
    Assinatura.ContentMailBody = Me.txtContent
    Else
    Assinatura.ContentMailBody = Me.txtFile
    End If
    Assinatura.GeraEmail

Olá Adelson!

Agradeço por estar me ajudando neste caso.

Você poderia me enviar um exemplo em Excel com este código?

Muito obrigado pela ajuda.

VOU TE ENVIAR SIM, ME PASSA SEU EMAIL QUE TE ENVIO A NOITE

Olá Adelson!

Segue meus e-mails:

[email protected]
[email protected]

Obrigado pela ajuda.

Boa tarde adelsonrms

Teria como vc disponibilizar um arquivo com esses códigos?!

Acredito que seria mais fácil para os demais participantes entenderem =), principalmente eu... hehe

Att, Binario

OK Binario, os disponibilizarei hoje a noite