MaximoAccess

Caro Usuário, não tire as suas duvidas nas Salas de Repositório, abra sempre um novo tópico relacionado, nas salas destinadas para o efeito, como Sala de Tabelas, Consultas, Formulários, Relatórios, Macros, Módulos e VBA.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Estou problema para anexar um relatorio

    Compartilhe

    vmorais96
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 3
    Registrado : 23/11/2016

    Estou problema para anexar um relatorio

    Mensagem  vmorais96 em Seg 05 Dez 2016, 15:09

    Boa tarde, Galera

    Não estou conseguindo anexar o relatório no e-mail

    segue o código abaixo

    Sub EnviaEmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim corpo As String
    Dim strReportName$
    Dim AttachmentPath$
    Dim subject$
    Dim email_to$
    Dim email_cc$
    'Variáveis
       strReportName = "Rel_Solicitacao"
       DoCmd.OutputTo acOutputReport, strReportName, acFormatPDF, CurrentProject.Path & _
                      "\" & "Solicitação de Tarefas - SGR - 00" & Forms!Frm_Solicitacao.Txt_Cod_Solicitacao & ".pdf", False
    'Anexa relatório em formato PDF no e-mail
       subject = "Solicitação de Tarefa - SGR - 00" & Forms!Frm_Solicitacao.Txt_Cod_Solicitacao & " - " & Forms!Frm_Solicitacao.Txt_Nome_Fantasia
       'AttachmentPath = CurrentProject.Path & "\" & "Solicitação de Tarefas - SGR - 00" & Forms!Frm_Solicitacao.Txt_Cod_Solicitacao & ".pdf"
       email_to = Forms!Frm_Solicitacao.Txt_Funcionario
       email_cc = Forms!Frm_Solicitacao.Texto98
      ' email_oculto =""
    'Define os controles para envio de e-mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    'Abre o Outlook.exe
               corpo = "

    ." _
               & "

    Segue referente a Solicitação n° 00" & Forms!Frm_Solicitacao.Txt_Cod_Solicitacao _
    _
    _
                 & "

    Status:   " & Forms!Frm_Solicitacao.Txt_Status _
                 & "

    Tarefa:   " & Forms!Frm_Solicitacao.Txt_Tarefa _
    _
    _
               & "

    Proprietário:   " & Forms!frm_solicitacaoMensagem.Txt_Proprietario _
               & "

    Mensagem:   " & Forms!frm_solicitacaoMensagem.Txt_Mensagem _
                  & "

    "
    'Corpo do e-mail em formato HTML
    With OutMail
           .Display
           .To = email_to
           .CC = email_cc
           '.BCC = email_oculto
           .subject = subject
           .Attachments.Add (AttachmentPath) """""esta dando erro nessa linha"""""
                   .HTMLBody = corpo & "
    " & .HTMLBody
           '.Send
    End With
    'Envia e-mail
       'On Error GoTo 0
       Set OutMail = Nothing
       Set OutApp = Nothing
    End Sub

    Alguém pode me ajudar, agradeço desde já

    avatar
    Noobezinho
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 2803
    Registrado : 29/06/2012

    Re: Estou problema para anexar um relatorio

    Mensagem  Noobezinho em Ter 06 Dez 2016, 00:08

    Meu Caro

    Experimente:

    .AddAttachment AttachmentPath


    [ ]'s


    .................................................................................
    Noobezinho

    * A solução funcionou?  [Você precisa estar registrado e conectado para ver esta imagem.] 
    Agradeça e feche o tópico clicando no botão Resolvido
    Se não sabe como, veja [Você precisa estar registrado e conectado para ver este link.].

    Como anexar imagem no teu post do fórum : [Você precisa estar registrado e conectado para ver este link.]

    * Criar arquivos.zip com o Winrar - veja [Você precisa estar registrado e conectado para ver este link.].

    Atualmente estou verificando se quem está pedindo ajuda, ajudamos e não retornou.
    Se a pessoa em questão não deu retorno, não tentarei ajudar novamente .

    vmorais96
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 3
    Registrado : 23/11/2016

    Re: Estou problema para anexar um relatorio

    Mensagem  vmorais96 em Ter 06 Dez 2016, 10:37

    Bom dia, Noobezinho

    Tentei com esse comando e deu erro na linha...

    Vc teria alguma alternativa??

    Obrigado pela atenção
    avatar
    Noobezinho
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 2803
    Registrado : 29/06/2012

    Re: Estou problema para anexar um relatorio

    Mensagem  Noobezinho em Ter 06 Dez 2016, 11:03

    Bem

    Esta é a função que uso:

    Veja se te ajuda.

    Analise, caso não consiga disponibilize as parte necessárias para o funcionamento,

    para que possamos analisar.

    Código:

    Public Function EnviarEmail()

    Dim Mens As CDO.message, strDados As String, TotReg As Long
    Dim Config As CDO.Configuration, k1, I As Byte
    Dim rsmail As Recordset
    'Se não houver registros, sai fora.
    If DCount("*", "qry_EnviarEmailsAuto") = 0 Then
       Exit Function
    End If
    'Se a data for igual a de hoje, ou seja, ja foi enviado emails no dia, sai fora
    If DLookup("DiaEnvio", "tbl_DadosEmail") = Date Then
       Exit Function
    End If
    Set rsmail = CurrentDb.OpenRecordset("qry_EnviarEmailsAuto")
    On Error GoTo erromail

    rsmail.MoveFirst
    rsmail.MoveLast
    rsmail.MoveFirst
    TotReg = rsmail.RecordCount
    'deixa visivel controles de aviso de envio de email.
    Forms!frm_MenuPrincipal!cxAv.Visible = True
    Forms!frm_MenuPrincipal!rotAvEmail.Visible = True
    'Forms!frm_Email_Locat!rotAvisoMail.Visible = True
    Forms!frm_MenuPrincipal.TimerInterval = 300

    'Colhe dados da tabela tbl_DadosEmail

    strDados = "[Email] & '|' & [Senha] & '|' & [Men] "

    strDados = DlookupX(strDados, "tbl_DadosEmail")

    k1 = Split(strDados, "|")


    Set Config = New CDO.Configuration

    With Config
    'gmail
    .Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
    .Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
    .Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = k1(0)
    .Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = k1(1)
    .Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60

    .Fields.Update

    End With

       Do While Not rsmail.EOF
          Set Mens = New CDO.message
          With Mens
             Set .Configuration = Config

             .From = k1(0)
             If Not IsNull(rsmail!Email1) Then
                .To = rsmail!Email1
             End If
            
             If Not IsNull(rsmail!Email2) Then
               .cc = rsmail!Email2
             End If

             If Not IsNull(rsmail!Email3) Then
               .BCC = rsmail!Email3
             End If
             .ReplyTo = "OutroEmail@Servidor.com"
             .BodyPart.Charset = "utf-8"
             .Subject = "Bloqueto Mensal - " & Format(rsmail!dt_Vencto, "mm/yyyy")
             .TextBody = ""
             .HTMLBody = k1(2)
             .AddAttachment rsmail!Local_PDF
             .Send
             rsmail.Edit
             rsmail!bol_Email = rsmail!bol_Email + 1
             rsmail.Update
             I = I + 1
             Forms!frm_MenuPrincipal!rotAvisoMail.Caption = I & " de " & TotReg & " Email enviados."
             'Pausa 2 ' se precisar dessa linha avise que envio a função
             rsmail.MoveNext
          End With
          
       Loop
       'Forms!frm_MenuPrincipal.TimerInterval = 0
       'Forms!frm_MenuPrincipal!cxAv.Visible = False
       'Forms!frm_MenuPrincipal!rotAvEmail.Visible = False
      
       'Salva a data na tabela, para que não se repita o envio de email no dia.
       'DoCmd.SetWarnings False
       'DoCmd.RunSQL "UPDATE tbl_DadosEmail SET tbl_DadosEmail.DiaEnvio = Date();"
       'DoCmd.SetWarnings True
      
      
    Set Mens = Nothing
    Set Config = Nothing

    erromail:
    If Err.Number <> 0 Then
       Debug.Print " Erro: " & Err.Number & " " & Err.Description
        Resume Next
    End If

    End Function


    .................................................................................
    Noobezinho

    * A solução funcionou?  [Você precisa estar registrado e conectado para ver esta imagem.] 
    Agradeça e feche o tópico clicando no botão Resolvido
    Se não sabe como, veja [Você precisa estar registrado e conectado para ver este link.].

    Como anexar imagem no teu post do fórum : [Você precisa estar registrado e conectado para ver este link.]

    * Criar arquivos.zip com o Winrar - veja [Você precisa estar registrado e conectado para ver este link.].

    Atualmente estou verificando se quem está pedindo ajuda, ajudamos e não retornou.
    Se a pessoa em questão não deu retorno, não tentarei ajudar novamente .

      Data/hora atual: Sex 26 Maio 2017, 04:34