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

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

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

Olá, Obrigado pela partilha.
Abraço

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