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