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

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

    Compartilhe

    PepeTuga
    Intermediário
    Intermediário

    Respeito às Regras 100%

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

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

    Mensagem  PepeTuga em Dom 17 Ago - 14: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

    PepeTuga
    Intermediário
    Intermediário

    Respeito às Regras 100%

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

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

    Mensagem  PepeTuga em Seg 25 Ago - 12: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

    ahteixeira
    Moderador
    Moderador

    Respeito às Regras 100%

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

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

    Mensagem  ahteixeira em Sab 30 Ago - 6:34

    Olá, Obrigado pela partilha.
    Abraço

      Data/hora atual: Sex 2 Dez - 23:35