Este fórum está sendo desativado

[hgt]

Prezados,

Estou com dificuldades em inserir minha assinatura do outlook via VBA, tentei várias macros mas nenhuma funcionou.

Abaixo a macro que estou usando:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim texto As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

linha = ActiveCell.Row - 1
If Target.Address = "$H$" & linha Then

If Plan1.Cells(linha, 8) = "Concluído" Then
texto = "Prezado(a) " & Plan1.Cells(linha, 4) & "," & vbCrLf & vbCrLf & _
"a) Sua amostra está disponível para retirada aqui no LRAC; por favor, informe o número de seu pedido (" & Plan1.Cells(linha, 1) & ") para retirada da amostra." & vbCrLf & vbCrLf & _
"b) Segue link com o mapa para localização do laboratório." & vbCrLf & _
"http://www.feq.unicamp.br/index.php/lra ... hegar-lrac" & vbCrLf & vbCrLf & _
"Atenciosamente,"
End If

With OutMail
.To = Plan1.Cells(linha, 7)
.CC = ""
.BCC = ""
.Subject = "Título do email"
.Body = texto
.Display 'Utilize Send para enviar o email sem abrir o Outlook
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End If
End Sub

------------

Vejam que não tem nenhuma informação de assinatura, pois tentei de tudo, aguardo a ajuda de alguém.

Muito obrigado pessoal

[alexandrevba]

Bom dia!!

Um das feras do excel/VBA tem muito a nos ensinar, muita coisa eu copiado ou adapto daqui.
http://www.rondebruin.nl/win/s1/outlook/signature.htm


Att

[hgt]

Oi Alexandre, muito obrigado pela ajuda.

Ficou ótimo, porém não estou conseguindo fundir as duas macros, se utilizo a macro da assinatura só ela quem aparece, tem como eu fazer esta fusão para enviar e-mail quando eu mudar uma condição de uma célula específica?

Obrigado

[alexandrevba]

Bom dia!!

Mostre a outra macro.

O meu problema é que eu não consigo testar pois eu não uso outlook do pacote (standar2010).

Att

[hgt]

Oi Alexandre, veja o que estou fazendo

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim texto As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    linha = ActiveCell.Row - 1
    If Target.Address = "$H$" & linha Then

        If Plan1.Cells(linha, 8) = "Concluído" Then
            texto = "Prezado(a) " & Plan1.Cells(linha, 4) & "," & vbCrLf & vbCrLf & _
                    "a) Sua amostra está disponível para retirada aqui no LRAC; por favor, informe o número de seu pedido (" & Plan1.Cells(linha, 1) & ") para retirada da amostra." & vbCrLf & vbCrLf & _
                    "b) Segue link com o mapa para localização do laboratório." & vbCrLf & _
                    "http://www.feq.unicamp.br/index.php/lrac2/como-chegar-lrac" & vbCrLf & vbCrLf & _
                    "Atenciosamente,"
        End If

        With OutMail
            .To = Plan1.Cells(linha, 7)
            .CC = ""
            .BCC = ""
            .Subject = "Título do email"
            .Body = texto
            .Display   'Utilize Send para enviar o email sem abrir o Outlook
        End With
        On Error GoTo 0

        Set OutMail = Nothing
        Set OutApp = Nothing
    End If
End Sub

Código: Selecionar todos

Sub Mail_Outlook_With_Signature_Html_1()
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "<H3><B>Prezado(a)</B></H3>" & "," & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    On Error Resume Next

    With OutMail
        .Display
        .To = "Plan1.Cells(linha, 7)"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & .HTMLBody
        .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Código: Selecionar todos

Function GetBoiler(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)
    GetBoiler = ts.readall
    ts.Close
End Function

[alexandrevba]

Boa tarde!!

Você quer fazer o quê com a rotina que está dentro da sua guia, adicionar a assinatura ?

Seria isso?

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim texto As String
Dim strbody As String 'Adicionar assinatura

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'Adicionar assinatura
strbody = "<H3><B>Prezado(a)</B></H3>" & "," & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"<A HREF=""http://www.rondebruin.nl/tips.htm"">Ron's Excel Page</A>" & _
"<br><br><B>Thank you</B>"


linha = ActiveCell.Row - 1
If Target.Address = "$H$" & linha Then

If Plan1.Cells(linha, 8) = "Concluído" Then
texto = "Prezado(a) " & Plan1.Cells(linha, 4) & "," & vbCrLf & vbCrLf & _
"a) Sua amostra está disponível para retirada aqui no LRAC; por favor, informe o número de seu pedido (" & Plan1.Cells(linha, 1) & ") para retirada da amostra." & vbCrLf & vbCrLf & _
"b) Segue link com o mapa para localização do laboratório." & vbCrLf & _
"http://www.feq.unicamp.br/index.php/lrac2/como-chegar-lrac" & vbCrLf & vbCrLf & _
"Atenciosamente,"
End If

With OutMail
    .To = Plan1.Cells(linha, 7)
    .CC = ""
    .BCC = ""
    .Subject = "Título do email"
    .Body = texto
    .Display 'Utilize Send para enviar o email sem abrir o Outlook
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End If
End Sub

att