Sauvegarder des mails et cocher une table acces

Commenter

Contenu du snippet

Ce code sert a transferer des email d'un répertoire outlook a un autre, a sauvegarder les mails et pieces jointes et a cocher un champ acces quand vous avec recu la piece jointe...
Il traite les mails dans l'ordre d'arrivé.

Un petit compteur pour le temps d'execution...

Source / Exemple :

'library a charger menu "outil" "reference": Microsoft ActiveX Data Objects 2.7 library




'ouverture de la table access "vérification siges.mdb" passe la valeur du champ "siges recu" de false a TRUE

'plante en cas d'élément different de mail!! (ex: evenement outlook)



Dim trouvé As Boolean

Dim objoutlook As Outlook.Application
Dim olns As Outlook.NameSpace
Dim mItem As Outlook.MailItem
Dim att As Outlook.Attachment
Dim fld As Outlook.MAPIFolder
Dim CompteurMAIL, compteurDES, compteurSIGES As Integer
Dim compteurMAJAcces As Integer

Dim message, NomDeMAILSurDisque, NomdEMAIL As String
Dim RepertoireMAIL, RepertoireSIGESBR, RepertoireSIGESMG, RepertoireSIGESVF As String
Dim RepertoireSIGESBR2, RepertoireSIGESMG2, RepertoireSIGESVF2 As String
Dim RepertoireSIGESnonzipBR, RepertoireSIGESnonzipMG, RepertoireSIGESnonzipVF As String

Dim RepertoireDESBR, RepertoireDESMG, RepertoireDESVF As String
Dim NomDeFichierSurDisque, NomDeFichier, Taille, nom, Emetteur, nomTest As String
Option Explicit

Public Sub TransfertPJAccessV3()
On Error GoTo errorhandler

'déclaration des variables locales
  Dim b, a As Integer
  Dim i, j, x As Integer
  Dim racine As String
  Dim d1 As Date, DateEnvoi1 As Date, DateEnvoi2 As Date, dFin As Date, dInter As Date
  
'Création de l'objet Outlook
Set objoutlook = CreateObject("Outlook.application")
'Récupération de l'espace de nom d'outlook
Set olns = objoutlook.GetNamespace("MAPI")
'Récupération du répertoire "boite de réception" par défault
Set fld = olns.GetDefaultFolder(olFolderInbox)
' Initialisation des reperetoires de sauvegarde
' ne pas oublier l'anti-slash à la fin du repertoire
racine = "S:\06 CARD\02_CARD\Applications\SIGES\Reprise\"
RepertoireSIGESBR = racine & "SIGES\BR\00_SIGES_Compresses\"
RepertoireSIGESVF = racine & "SIGES\VF\00_SIGES_Compresses\"
RepertoireSIGESMG = racine & "SIGES\MG\00_SIGES_Compresses\"
RepertoireSIGESnonzipBR = racine & "SIGES\BR\01_SIGES_A_MAJ\"
RepertoireSIGESnonzipVF = racine & "SIGES\VF\01_SIGES_A_MAJ\"
RepertoireSIGESnonzipMG = racine & "SIGES\MG\01_SIGES_A_MAJ\"
'Repertoire = "M:\Siges_recus\export PJ outlook\"

RepertoireSIGESBR2 = "M:\Siges_recus\export SIGES outlook\BR\"
RepertoireSIGESVF2 = "M:\Siges_recus\export SIGES outlook\VF\"
RepertoireSIGESMG2 = "M:\Siges_recus\export SIGES outlook\MG\"

RepertoireDESBR = racine & "Ventes\BR\00_fichiers_Compresses\"
RepertoireDESVF = racine & "Ventes\VF\00_fichiers_Compresses\"
RepertoireDESMG = racine & "Ventes\MG\00_fichiers_Compresses\"

RepertoireMAIL = "M:\Siges_recus\export MAIL outlook\"

'Inialisation des variables Message, NomDeFichier, NomDeFichierSurDisque, Taille, Emetteur
message = NomDeMAILSurDisque = NomDeFichierSurDisque = nom = NomDeFichier = Taille = Emetteur = ""
  
' Initialisation
CompteurMAIL = 0
compteurSIGES = 0
compteurDES = 0
compteurMAJAcces = 0
' Sauve les pieces jointes des mails se trouvant dans la boîte de réception.
' Pour adresser un dossier dans la boite de réception on pourrait utiliser :
'fld.Folders(".SIGES").Items

' Confirmation du début de la procedure de traitement
a = MsgBox("Etes-vous sûr de vouloir lancer la récupérations des (Mails / Pieces jointes) contenus dans .SIGES?", vbYesNo)
If (a <> 6) Then Exit Sub
 
d1 = Time

début:
x = 0
i = 1
j = fld.Folders(".SIGES").Items.Count
If j = 0 Then GoTo fin

DateEnvoi1 = fld.Folders(".SIGES").Items(1).ReceivedTime


For i = 1 To j

  DateEnvoi2 = fld.Folders(".SIGES").Items(i).ReceivedTime
  If DateEnvoi2 < DateEnvoi1 Then DateEnvoi1 = DateEnvoi2

Next
For i = 1 To j

  If fld.Folders(".SIGES").Items(i).ReceivedTime = DateEnvoi1 Then x = i
   

Next
 

'**Boucle pour parcourir tous les MAIL du répertoire ".SIGES" de la boite de reception
For Each mItem In fld.Folders(".SIGES").Items

If mItem.ReceivedTime = DateEnvoi1 Then
     

    Taille = mItem.Size
    Emetteur = mItem.SenderName
    NomdEMAIL = mItem.Subject
    
    nom = NomdEMAIL
    'supression des caratères qui bloquent le programme au niveau de l'objet pour la sauvegarde du mail sur disque.
    Do While InStr(1, nom, ":") <> 0
        nom = Left(nom, InStr(1, nom, ":") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, ":"))
    Loop
    
    Do While InStr(1, nom, "/") <> 0
        nom = Left(nom, InStr(1, nom, "/") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, "/"))
    Loop
    
    Do While InStr(1, nom, "\") <> 0
        nom = Left(nom, InStr(1, nom, "\") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, "\"))
    Loop
    
    Do While InStr(1, nom, ";") <> 0
        nom = Left(nom, InStr(1, nom, ";") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, ";"))
    Loop
    
    Do While InStr(1, nom, ".") <> 0
        nom = Left(nom, InStr(1, nom, ".") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, "."))
    Loop
    
    Do While InStr(1, nom, "'") <> 0
        nom = Left(nom, InStr(1, nom, "'") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, "'"))
    Loop
    
    Do While InStr(1, nom, "?") <> 0
        nom = Left(nom, InStr(1, nom, "?") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, "?"))
    Loop
    
    Do While InStr(1, nom, "%") <> 0
        nom = Left(nom, InStr(1, nom, "%") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, "%"))
    Loop
    
    Do While InStr(1, nom, "^") <> 0
        nom = Left(nom, InStr(1, nom, "^") - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, "^"))
    Loop
    
    'exclusion du double cote "
    Do While InStr(1, nom, Chr(34)) <> 0
        nom = Left(nom, InStr(1, nom, Chr(34)) - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, Chr(34)))
    Loop
    
    'exclusion de étoile *
    Do While InStr(1, nom, Chr(42)) <> 0
        nom = (Left(nom, InStr(1, nom, Chr(42)) - 1) & " " & Right(nom, Len(nom) - InStr(1, nom, Chr(42))))
    Loop
    
    
    
    NomdEMAIL = nom
    
    'nomTest = mItem.Name
    

    NomDeMAILSurDisque = Emetteur & " " & Taille & " octet " & NomdEMAIL & ".msg"

    'copie du MAIL sous forme spéciale sur archive
    mItem.SaveAs (RepertoireMAIL & NomDeMAILSurDisque)


'compte les nombres de mail copiés
    CompteurMAIL = CompteurMAIL + 1
'Initialisation de la boucle
    i = 1
    'Boucle pour faire toutes les pieces jointes d'un mail
        Do While i < mItem.Attachments.Count + 1
        
            
            ' Nom du fichier modifié pour l'enregistrement. Evite les controles superflus en renommant.
            'Taille = mItem.Size
            'Emetteur = mItem.SenderName
            NomDeFichier = mItem.Attachments.Item(i).FileName
            
            'elements de taille du message permet la copie meme en cas de pieces jointes identiques sur messages différents
            
            NomDeMAILSurDisque = Emetteur & " (" & Taille & " octets) " & NomdEMAIL
            NomDeFichierSurDisque = NomDeFichier
            
            'mItem.Attachments.Item(i).SaveAsFile Repertoire & NomDeFichierSurDisque
           
            
            With mItem.Attachments.Item(i)
              Select Case Right(NomDeFichier, 3)
                Case "zip":
                
                    Select Case Left(NomDeFichier, 8)
                        Case "SIGES_BR":
                         .SaveAsFile RepertoireSIGESBR & NomDeFichierSurDisque
                          .SaveAsFile RepertoireSIGESBR2 & NomDeFichierSurDisque
                           compteurSIGES = compteurSIGES + 1
                        Case "SIGES_MG":
                          .SaveAsFile RepertoireSIGESMG & NomDeFichierSurDisque
                          .SaveAsFile RepertoireSIGESMG2 & NomDeFichierSurDisque
                          compteurSIGES = compteurSIGES + 1
                        Case "SIGES_AR":
                           .SaveAsFile RepertoireSIGESVF & NomDeFichierSurDisque
                          .SaveAsFile RepertoireSIGESVF2 & NomDeFichierSurDisque
                          compteurSIGES = compteurSIGES + 1
                         End Select
            
            
                     Select Case Left(NomDeFichier, 13)
                         Case "DESCRIPTIF_BR":
                             .SaveAsFile RepertoireDESBR & NomDeFichierSurDisque
                              compteurDES = compteurDES + 1
                         Case "DESCRIPTIF_MG":
                              .SaveAsFile RepertoireDESMG & NomDeFichierSurDisque
                              compteurDES = compteurDES + 1
                         Case "DESCRIPTIF_AR":
                              .SaveAsFile RepertoireDESVF & NomDeFichierSurDisque
                              compteurDES = compteurDES + 1
                      End Select
                
                Case "xls":
                         
                         Select Case Left(NomDeFichier, 8)
                        Case "SIGES_BR":
                         .SaveAsFile RepertoireSIGESnonzipBR & NomDeFichierSurDisque
                          .SaveAsFile RepertoireSIGESBR2 & NomDeFichierSurDisque
                           compteurSIGES = compteurSIGES + 1
                        Case "SIGES_MG":
                          .SaveAsFile RepertoireSIGESnonzipMG & NomDeFichierSurDisque
                          .SaveAsFile RepertoireSIGESMG2 & NomDeFichierSurDisque
                          compteurSIGES = compteurSIGES + 1
                        Case "SIGES_AR":
                           .SaveAsFile RepertoireSIGESnonzipVF & NomDeFichierSurDisque
                          .SaveAsFile RepertoireSIGESVF2 & NomDeFichierSurDisque
                          compteurSIGES = compteurSIGES + 1
                         End Select
                                
                End Select
                
                Select Case Left(NomDeFichier, 8)
                    Case "SIGES_BR":
                        Call aCCesBR
                    Case "SIGES_AR":
                        Call aCCesAR
                    Case "SIGES_MG":
                        Call aCCesMG
                End Select
            
            End With
            
            
     
        
        i = i + 1
        
        Loop
    
'marquer comme non lu et transferer le message dans le repertoire .SIGES sauvé
fld.Folders(".SIGES").Items(x).UnRead = True ' marqueur message non lu
fld.Folders(".SIGES").Items(x).Move fld.Folders(".SIGES extraits")
   
End If

Next

GoTo début:

fin:
'***Calcul du temps de traitement
dFin = Time
dInter = dFin - d1




' Message du nombre de PJ enregisté
If CompteurMAIL > 0 Then

       MsgBox " -> " & CompteurMAIL & " MAIL copié(s) dans " & _
            "" & RepertoireMAIL & Chr(13) & _
            " -> " & compteurSIGES & _
            " SIGES copié(s) dans" & Chr(13) & "    - S:\06 CARD\02_CARD\Applications\SIGES\Reprise\SIGES\" & Chr(13) & _
            "    - M:\Siges_recus\export PJ outlook\" & Chr(13) & _
            " -> " & compteurDES & " Descriptifs copié(s) dans S:\06 CARD\02_CARD\Applications\SIGES\Reprise\Ventes" & Chr(13) & _
            " -> " & compteurMAJAcces & " Mises à jour ACCESS " & Chr(13) & _
            " -> Temps de traitement : " & Format(Hour(dInter), "00") & "h:" & _
            Format(Minute(dInter), "00") & "min:" & Format(Second(dInter), "00") & "sec.", _
            vbInformation, "Fin de procédure de Récupération des Pièces-jointes et de sauvegarde des Mails"
Else

    b = MsgBox("Aucun message a traiter")
    
End If
'Dé-instanciation
Set objoutlook = Nothing
Set olns = Nothing
Set fld = Nothing

Exit Sub
  
errorhandler:
MsgBox Err.Description, , Err.Source
End Sub

'*********
'Fonctions de modifs ACCES non optimiser en place: facturation au kilo :-p
'*********

Function aCCesBR()



Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
'Ouvre la base de données Access
db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=S:\06 CARD\02_CARD\Applications\SIGES\Reprise\SIGES\Vérification SIGES.mdb"
'Ouvre une table
rs.Open "SIGES_BR", db, adOpenStatic, adLockOptimistic
'Contrôle si il y a au moins une ligne
If rs.RecordCount > 0 Then
'Fais une boucle jusqu'à la dernière ligne
  rs.MoveFirst
  trouvé = False
    Do While rs.EOF = False And trouvé = False
'Modifie la valeur
       If rs.Fields("N° Section").Value = Mid(NomDeFichierSurDisque, 7, 5) Then
        rs.Fields("reçu SIGES").Value = True 'Nouvelle valeur
        trouvé = True
        compteurMAJAcces = compteurMAJAcces + 1
       End If
'Enregistre
        rs.Update
'Va au suivant
        rs.MoveNext
        Loop
End If
'Ferme
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing

End Function

Function aCCesMG()



Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
'Ouvre la base de données Access
db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=S:\06 CARD\02_CARD\Applications\SIGES\Reprise\SIGES\Vérification SIGES.mdb"
'Ouvre une table
rs.Open "SIGES_MGB", db, adOpenStatic, adLockOptimistic
'Contrôle si il y a au moins une ligne
If rs.RecordCount > 0 Then
'Fais une boucle jusqu'à la dernière ligne
  rs.MoveFirst
  trouvé = False
    Do While rs.EOF = False And trouvé = False
'Modifie la valeur
       If rs.Fields("N° Section").Value = Mid(NomDeFichierSurDisque, 7, 5) Then
        rs.Fields("reçu SIGES").Value = True 'Nouvelle valeur
        trouvé = True
        compteurMAJAcces = compteurMAJAcces + 1
       End If
'Enregistre
        rs.Update
'Va au suivant
        rs.MoveNext
        Loop
End If
'Ferme
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing

End Function

Function aCCesAR()



Dim db As New ADODB.Connection
Dim rs As New ADODB.Recordset
'Ouvre la base de données Access
db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=S:\06 CARD\02_CARD\Applications\SIGES\Reprise\SIGES\Vérification SIGES.mdb"
'Ouvre une table
rs.Open "SIGES_VDF", db, adOpenStatic, adLockOptimistic
'Contrôle si il y a au moins une ligne
If rs.RecordCount > 0 Then
'Fais une boucle jusqu'à la dernière ligne
  rs.MoveFirst
  
  trouvé = False
    Do While rs.EOF = False And trouvé = False
'Modifie la valeur
       If rs.Fields("N° Section").Value = Mid(NomDeFichierSurDisque, 7, 5) Then
        
        rs.Fields("reçu SIGES").Value = True 'Nouvelle valeur
        trouvé = True
        compteurMAJAcces = compteurMAJAcces + 1
       End If
'Enregistre
        rs.Update
'Va au suivant
        rs.MoveNext
        Loop
End If
'Ferme
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing

End Function

Conclusion :

J'ai utilisé diverses sources de VBfrance alors je poste ma production pour eventuellement aider quelqu'un autant que ce site m'a aidé...
excusez la qualité du code qui n'est pas fameuse (notement la boucle de recherche du premier mail recu) mais il marche bien :-)

A voir également

Du même auteur (yannlevrai)