Tomás Vásquez Fórum

Enviado: **Ter Jul 30, 2019 2:48 pm**

Olá pessoal!
Tenho uma macro para envio de e-mails, e preciso inserir a assinatura padrão da conta no envio.
A macro envia um e-mail com anexo, texto e imagem no corpo. O envio é realizado por outra conta (corporativa), por isso é enviado pelo e-mail secundário direto do servidor.
Porém, a macro não insere a assinatura da conta. É possível realizar a inserção sem precisar mudar toda a estrutura da macro?
Segue o código:

Código: Selecionar todos

Option Explicit

Dim lSalvar As String


Sub ArquivoAnexo()

Dim OutApp As Object
Dim OutMail As Object
Dim oEmail As Object
Dim strBody As String

Dim linha As String
Dim assunto As String
Dim destino As String
Dim anexo As String
Dim produto As String
Dim unidade As String
Dim retval As String
Dim nome_anexo As String
Dim validacao As String
Dim assinatura As String


linha = 3

produto = "x"

Do While produto <> ""
    
    Set oEmail = CreateObject("CDO.Message")

    produto = Sheets("Envio_Emails").Range("M" & linha)
    unidade = Sheets("Envio_Emails").Range("N" & linha)
    destino = Sheets("Envio_Emails").Range("O" & linha)
    assunto = Sheets("Envio_Emails").Range("P" & linha)
    anexo = Sheets("Envio_Emails").Range("Q" & linha)
    nome_anexo = Sheets("Envio_Emails").Range("R" & linha)
    validacao = Sheets("Envio_Emails").Range("L" & linha)
       
    Sheets("Envio_Emails").Range("S1") = produto
      
    retval = Dir(anexo)

    If retval = nome_anexo Then
        
    Else
        GoTo proximo_anexo
    End If
    
    If anexo = "" Then
        GoTo proximo_anexo
    End If
    
    Sheets("Envio_Emails").Select
    ActiveSheet.Calculate
    
    Select Case produto
    
        Case Is = "X"
            Sheets("RESULTADO_X").Select
            Range("K3") = unidade
            ActiveSheet.Calculate
            
        Case Is = "Y"
            If validacao = "Enviar" Then
                Sheets("RESULTADO_Y").Select
                Range("K3") = unidade
                ActiveSheet.Calculate
            Else: GoTo proximo_anexo
            
            End If
    End Select
    
    On Error Resume Next

    Call lCriarImagem
    
    'strBody = "<body> </h2>Olá!<br/> <br/></h2>Segue a prévia do IRC de Junho.<h2> </h2> </h2><br/> <img src=""" & lSalvar & """ style=""""></body>"
     strBody = Sheets("Envio_Emails").Range("B9") & "<img src=""" & lSalvar & """ style=""""></body>"
     
    'UTILIZAR O SITE https://wordtohtml.net/ PARA GERAR O HTML
        
    With oEmail
    
    .Display
    oEmail.From = "EMAIL@ENVIO"
    oEmail.To = "EMAIL@RECEBIMENTO"
    oEmail.Subject = assunto
    oEmail.AddAttachment anexo
    oEmail.HTMLBody = strBody & .HTMLBody
    
    oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "meuserver.server"
    oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/authenticate") = 1
    
    ''''''
    ''''''
    '''''
    oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

    oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "email_login"
    oEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "email_senha"
    '''''
    ''''''
    ''''''
    
    oEmail.Configuration.Fields.Update
    
    oEmail.Send
    
    End With
    
    'MsgBox "Arquivo enviado com sucesso!", vbInformation
    
    On Error GoTo 0
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
proximo_anexo:
    
    linha = linha + 1
    
Loop

End Sub

Desde já, muito obrigado!

Tomás Vásquez Fórum

Incluir assinatura CDO

Incluir assinatura CDO