Esqueceu sua senha? Você pode usar o mecanismo de lembrete neste link: Recuperar senha

Você receberá um link de reativação no email cadastrado.

Não recebeu o email? Lembre-se checar o Lixo Eletrônico.

Incluir assinatura CDO

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
leonardompires
Acabou de chegar
Acabou de chegar
Mensagens: 1
Registrado em: Seg Jul 29, 2019 5:14 pm

Incluir assinatura CDO

Mensagem por leonardompires » 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!



Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder