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


3 participantes

    [Resolvido]Enviar vários anexos de uma pasta por email

    avatar
    PepeTuga
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 91
    Registrado : 17/10/2013

    [Resolvido]Enviar vários anexos de uma pasta por email Empty [Resolvido]Enviar vários anexos de uma pasta por email

    Mensagem  PepeTuga 17/8/2014, 19:05

    Boa tarde Pessoal!

    Já levei horas a pesquisar no fórum e em vários sites na internet e não consegui encontrar o que preciso.

    Pretendo um código que faça o seguinte:
    1. Abrir mensagem email Outlook, uma por cada código de cliente que se encontram listados num subformulário (através de Loop);
    2. Anexar vários ficheiros pdf de uma pasta. Neste processo, os anexos devem apenas corresponder a cada código de cliente sendo que cada ficheiro está identificado da seguinte forma: 99887766_123456 (Código Cliente_nº de envio).

    O código abaixo faz o que pretendo com exceção do ponto 2:

    Me.Clientes_subformulário.SetFocus
       DoCmd.GoToRecord , "", acFirst
               'Dim rst As DAO.Recordset
               Set rst1 = Me.Clientes.Form.Recordset
               Do Until rst1.EOF
                   Dim OutApp As Object
                   Dim OutMail As Object
                   Dim rst As DAO.Recordset
                   Set OutApp = CreateObject("Outlook.Application")
                   OutApp.Session.Logon
                   Set OutMail = OutApp.CreateItem(0)
                   
                   With OutMail
                   .To = Me.Clientes_subformulário.Form.Texto7 & ";" & Me.Clientes_subformulário.Form.Texto9
                   .BCC = ""
                   .Subject = ""
                   .Body = ""
                   .Attachments.Add
                   .Display
                   
                   rst.Close
                   End With
                   Set OutMail = Nothing
                   Set OutApp = Nothing
                   Set rst = Nothing
               rst1.MoveNext
                       
               Loop
    End Sub

    Se alguém puder dar uma dica fico bastante agradecido.
    Abraço,
    PepeTuga
    avatar
    PepeTuga
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 91
    Registrado : 17/10/2013

    [Resolvido]Enviar vários anexos de uma pasta por email Empty Re: [Resolvido]Enviar vários anexos de uma pasta por email

    Mensagem  PepeTuga 25/8/2014, 17:49

    Caros colegas e amigos do Fórum,

    Aqui vai a solução para este tópico.

    Este projeto tem a seguinte construção:
    1. Criação de 2 pastas (Utilizador e FicheirosTemp) numa origem à sua escolha;
    2. Criação de 3 tabelas: Ficheiros (IDCliente;Utilizador;Caminho), FicheirosAnexos (IDCliente;Utilizador;Caminho) e Ficheiros_EnviarAnexos (IDCliente;Utilizador);
    3. Criação de 2 consultas de acrescento: FicheirosAnexos_Adicionar (IDCliente;Utilizador;Caminho) e Ficheiros_EnviarAnexos_Adicionar (Código;Utilizador);
    4. Criação de 3 consultas de eliminação: Ficheiros_Eliminar (IDCliente;Utilizador;Caminho), FicheirosAnexos_Eliminar (IDCliente;Utilizador;Caminho) e Ficheiros_EnviarAnexos_Eliminar (IDCliente;Utilizador);
    5. Criação de 1 formulário (Envio) sem qualquer dependência e dentro deste um subformulário (Envio_subformulário) com dados agrupados da tabela Ficheiros_EnviarAnexos (IDCliente;Utilizador);
    6. No formulário onde pretende iniciar o processo de envio de e-mails com anexos, adicione um botão com o seguinte evento:

    Habilite a referência "Microsoft Scripting Runtime"
    On Error GoTo PastaInexistente:
    Dim TheFile As String
    Dim Results As String
     
       Dim fso As New FileSystemObject
       Dim result() As String
       Dim Pasta As Folder
       Dim Arquivo As File
       Dim Indice As Long
       ReDim result(0) As String
       
    'Verifica se existe ficheiro de importação na pasta de origem
       TheFile = "C:\Users\" & Me.Utilizador & "\*.pdf"""
       Results = Dir$(TheFile)
           'Se não existe
            If Results = "" Then
               MsgBox "Não existem ficheiros pendentes de envio deste Utilizador!", vbCritical, "Assistent!"
            'Se existe
            Else
       ‘Copiar ficheiros para uma pasta temporária      
       Dim fso1
       Dim strOrigem As String, strDestino As String
       strOrigem = "C:\Users\" & Me.Utilizador ' caminho de origem da pasta"
       strDestino = "C:\Users\FicheirosTemp\" & Me.Utilizador & "FicheirosTemp"  ' caminho de destino"
       Set fso1 = CreateObject("Scripting.FileSystemObject")
       fso1.CopyFolder strOrigem, strDestino
     
       'Ler e Inserir nome do ficheiro, utilizador e caminho na tabela Anexos
               If fso.FolderExists("C:\Users\FicheirosTemp\" & Me.Utilizador & "FicheirosTemp") Then
               Set Pasta = fso.GetFolder("C:\Users\FicheirosTemp\" & Me.Utilizador & "FicheirosTemp")
               
               For Each Arquivo In Pasta.Files
               Indice = IIf(result(0) = "", 0, Indice + 1)
               ReDim Preserve result(Indice) As String
               result(Indice) = Arquivo.Name
         
           'Campos que devem existir no formulário onde é executado o comando
           Me.Texto291 = result(Indice)
           Me.Texto299 = Me.Utilizador
           Me.Texto302 = strOrigem & "\" & result(Indice)
           
           CurrentDb.Execute "INSERT INTO Anexos(ID_Fornecedor,Utilizador,Caminho) VALUES('" & Me.Texto291 & "','" & Me.Texto299 & "','" & Me.Texto302 & "');"
           
           'Eliminar o ficheiro lido e inserido na tabela da pasta FicheirosTemp
           Kill "C:\Users\Pedro & Cátia\Desktop\FicheirosTemp\" & Me.Utilizador & "FicheirosTemp\" & Me.Texto291
           'Limpar os campos
           Me.Texto291.Undo
           Me.Texto302.Undo
           Next
           Set fso = Nothing
           Set Pasta = Nothing
           Set Arquivo = Nothing
           'Transferência dos nomes dos ficheiros para tabela de envio
           DoCmd.OpenQuery "Ficheiros_EnviarAnexos_Adicionar"
           'Abrir formulário de envio
           DoCmd.OpenForm "Envio"
           End If    
    End If
    PastaInexistente:
    If Err.Number = 73 Then
    MsgBox "Não existe pasta deste utilizador definida! Contate o administrador do programa.", vbCritical, "Erro!"
    Resume Next
    End If
    End If
    End Sub

    7. No formulário (Envio) adicione um botão com o seguinte evento:

    Habilite a referência "Microsoft Outlook 12.0 Object Library"
    On Error GoTo TrataErro:
    If MsgBox("Depois de iniciar o processo de envio todos os ficheiros da pasta deste utilizador serão ELIMINADAS! " & _
           vbCrLf & "" & _
           vbCrLf & "Deseja Continuar?", vbQuestion + vbYesNo, "ImporDados") = vbYes Then

    Me.Envio_subformulário.SetFocus
    DoCmd.GoToRecord , "", acFirst
           
               'Dim rst As DAO.Recordset
               Set rst1 = Me. Envio_subformulário.Form.Recordset
               Do Until rst1.EOF
               'Application.DoCmd.SetWarnings False

    'Adicionar anexos na tabela
    DoCmd.OpenQuery " FicheirosAnexos_Adicionar "

    'Criar e-mail
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim objOutlookAttach As Outlook.Attachment

    Set olApp = New Outlook.Application
    Set olMail = olApp.CreateItem(olMailItem)

    With olMail
       .BodyFormat = olFormatHTML
       .ReadReceiptRequested = True
       .Importance = 2
       .To = ""
       .CC = ""
       .Subject = ""
       .Body = ""
       'Anexar ficheiros
       Dim db As DAO.Database
       Dim rstAttachments As DAO.Recordset
           
       Set db = CurrentDb()
       Set rstAttachments = db.OpenRecordset("Select Caminho from Ficheiros_Anexos")
       
       If rstAttachments.RecordCount > 0 Then
           With rstAttachments
               Do Until .EOF
                       'If DoesFileExist(rstAttachments!Caminho) Then
                       olMail.Attachments.Add (rstAttachments!Caminho)
                       'End If
                   .MoveNext
               Loop
           End With
       End If

       .Save
       .Display
    End With

    Set olMail = Nothing
    Set objOutlookAttach = Nothing
    Set olApp = Nothing
    Set rstAttachments = Nothing
    Set db = Nothing

    'Limpar tabelas
    DoCmd.OpenQuery "Ficheiros_Eliminar"
    DoCmd.OpenQuery "FicheirosAnexos_Eliminar"
    DoCmd.OpenQuery "Ficheiros_EnviarAnexos_Eliminar"
               rst1.MoveNext
               Loop
             

    'Limpar a pasta de anexos do “Utilizador”
    Kill "C:\Users\" & Me.Utilizador & "\*.pdf"""
    Me.Refresh

    TrataErro:
    If Err.Number = 2105 Then
    MsgBox "Não existem ficheiros pendentes de envio deste Utilizador!", vbExclamation, "Sistema!"
    Else
    Resume Next
    End If

    End If

    End Sub

    NOTA: O utilizador deve guardar os ficheiros na pasta (Utilizador) com o nome do IDCliente separado por "-" ou "_" do nome do ficheiro. Exemplo: 123456_nomeficheiro. As consultas de acrescento: FicheirosAnexos_Adicionar (IDCliente;Utilizador;Caminho) e Ficheiros_EnviarAnexos_Adicionar (Código;Utilizador), devem conter a função: Esquerda([IDCliente];6) para que os valores a enviar para as tabelas correspondam ao IDCliente da tabela de "Clientes" que já deve fazer parte da BD.

    Com algum estudo e respetiva adaptação poderão implementá-lo nos vossos projetos.

    Resolvido!

    Abraço,
    PepeTuga
    Alvaro Teixeira
    Alvaro Teixeira
    Moderador Global
    Moderador Global


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7996
    Registrado : 15/03/2013

    [Resolvido]Enviar vários anexos de uma pasta por email Empty Re: [Resolvido]Enviar vários anexos de uma pasta por email

    Mensagem  Alvaro Teixeira 30/8/2014, 11:34

    Olá, Obrigado pela partilha.
    Abraço
    avatar
    santosj1966
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Anónimo
    Mensagens : 9
    Registrado : 15/09/2015

    [Resolvido]Enviar vários anexos de uma pasta por email Empty Re: [Resolvido]Enviar vários anexos de uma pasta por email

    Mensagem  santosj1966 12/4/2024, 12:43

    Olá,
    Fiz uma adaptação ao Vb e elele envia o mail só que não envia os anexos, podem ajudar?

    'Criar e-mail

    Set omsg = CreateObject("CDO.message")
    With omsg.Configuration.Fields
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "in-smtprelay-pfr00.essilor.com"
    .Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 25
    '.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    '.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    '.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
    '.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "clone@essilor.pt"
    '.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "2002clone"
    .Update
    End With
    ' build email parts
    With omsg
    .To = ""
    '.To = ""
    '.To = ""
    '.CC = ""
    '.Cc = ""
    .From = ""
    .Subject = "ENCOMENDAS DIARIAS e MENSAIS"
    .TextBody = "Anexo os registos ENTRY ORDERS diário e mensal. Ao dispor"

      'Anexar ficheiros
      Dim db As DAO.Database
      Dim rstAttachments As DAO.Recordset
         
      Set db = CurrentDb()
          Set rstAttachments = db.OpenRecordset("Select Caminho from FicheirosAnexos")
     
      If rstAttachments.RecordCount > 0 Then
          With rstAttachments
              Do Until .EOF
                      'If DoesFileExist(rstAttachments!Caminho) Then
                      omsg.Attachments.Add (rstAttachments!Caminho)
                      'End If
                  .MoveNext
              Loop
          End With
      End If
     
      .Save
      .Display
      .Send
     
    End With

    Conteúdo patrocinado


    [Resolvido]Enviar vários anexos de uma pasta por email Empty Re: [Resolvido]Enviar vários anexos de uma pasta por email

    Mensagem  Conteúdo patrocinado


      Data/hora atual: 21/11/2024, 15:40