MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

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

2 participantes

    Estou problema para anexar um relatorio

    avatar
    vmorais96
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

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

    Estou problema para anexar um relatorio  Empty Estou problema para anexar um relatorio

    Mensagem  vmorais96 5/12/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á

    Noobezinho
    Noobezinho
    Moderador
    Moderador


    Respeito às regras : Respeito às Regras 100%

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

    Estou problema para anexar um relatorio  Empty Re: Estou problema para anexar um relatorio

    Mensagem  Noobezinho 6/12/2016, 00:08

    Meu Caro

    Experimente:

    .AddAttachment AttachmentPath


    [ ]'s


    .................................................................................
    A pergunta que não quer calar:
    Por quê quando alguém vem pedir ajuda e conforme o caso pedimos
    para enviar parte do projeto, não temos mais continuidade do tópico?  
    Crê que temos bolas de cristal ou está com medo que "roubemos"  a
    idéia/projeto dele?  Twisted Evil
    Se é tão bom assim...


    Ajude a ser ajudado:
    Seja objetivo na dúvida, dê os detalhes do que precisa, sem rodeios.
    Quando anexar teu projeto, diga onde está o problema, ganhamos mais tempo
    sem precisar procurar o mesmo.
    avatar
    vmorais96
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

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

    Estou problema para anexar um relatorio  Empty Re: Estou problema para anexar um relatorio

    Mensagem  vmorais96 6/12/2016, 10:37

    Bom dia, Noobezinho

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

    Vc teria alguma alternativa??

    Obrigado pela atenção
    Noobezinho
    Noobezinho
    Moderador
    Moderador


    Respeito às regras : Respeito às Regras 100%

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

    Estou problema para anexar um relatorio  Empty Re: Estou problema para anexar um relatorio

    Mensagem  Noobezinho 6/12/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


    .................................................................................
    A pergunta que não quer calar:
    Por quê quando alguém vem pedir ajuda e conforme o caso pedimos
    para enviar parte do projeto, não temos mais continuidade do tópico?  
    Crê que temos bolas de cristal ou está com medo que "roubemos"  a
    idéia/projeto dele?  Twisted Evil
    Se é tão bom assim...


    Ajude a ser ajudado:
    Seja objetivo na dúvida, dê os detalhes do que precisa, sem rodeios.
    Quando anexar teu projeto, diga onde está o problema, ganhamos mais tempo
    sem precisar procurar o mesmo.

      Data/hora atual: 22/1/2022, 17:35