Sub recupere_les_messages_outlook_dans_une_table()
'gestion des erreurs
On Error GoTo gere
'déclaration des variables de travail
Dim stPJointes As String
Dim olkapp As Object
Dim olknamespace As Object
Dim objOLfolder As Outlook.MAPIFolder
Dim I As Integer
Dim marequete As String
Dim Repertoire, NomDeFichierSurDisque, NomDeFichier As String
Dim code As String 'pour le chronoMesEmis
Dim messag As String
Dim Datee As String
DoCmd.SetWarnings False 'sinon il va te demander a chaque fois voulez vous supprimer
'DoCmd.RunSQL "DELETE * FROM BoiteDeRéception;"
DoCmd.SetWarnings True 'remet l'affichage des messages d'erreurs
'ouverture de l'object outlook
Set olkapp = CreateObject("Outlook.application")
Set olknamespace = olkapp.GetNamespace("MAPI")
'-----------------------------------------------------------
' Initialisation du reperetoire de sauvegarde
' ne pas oublier l'anti-slash à la fin du repertoire
Repertoire = "C:\message\"
'Inialisation des variables NomDeFichier, NomDeFichierSurDisque
NomDeFichierSurDisque = NomDeFichier = ""
'ouverture des dossiers de mails
Set objOLfolder = olknamespace.GetDefaultFolder(olFolderInbox)
'informations sur le nombre de mails trouvés
MsgBox ("Access a trouvé : " & objOLfolder.Items.Count & " mail(s) dans votre boite de réception !")
'aucun mail n'a été trouvé ? => on sort !
If objOLfolder.Items.Count = 0 Then
Exit Sub
End If
'on désactive les avertissements
DoCmd.SetWarnings False
Find = Chr(34)
repl = "'"
'passage en revue des mails et écriture dans la table
'des champs suivants SUJET,DESTINATAIRE,DATE ENVOI,DATE RECU
For I = objOLfolder.Items.Count To 1 Step -1
'pour enregistre les pièces jointes dans la table
For Each myatt In objOLfolder.Items(I).Attachments
If stPJointes = "" Then
stPJointes = myatt.FileName
NomDeFichierSurDisque = stPJointes
'------ pour l'enregistrement sur le disque ------
myatt.SaveAsFile Repertoire & NomDeFichierSurDisque
Else
NomDeFichierSurDisque = myatt.FileName
'------ pour l'enregistrement sur le disque ------
myatt.SaveAsFile Repertoire & NomDeFichierSurDisque
stPJointes = stPJointes & "," & myatt.FileName
End If
Next
'pour remplacer le caractère " dans le sujet par un espace ou le carctère '
nouvsujet = Replace(Replace(objOLfolder.Items(I).Subject, Find, repl), "'", " ")
'pour supprimer le reste du chronoMesEmis et avoir selement le code
code = objOLfolder.Items(I).CC
marequete = "INSERT INTO BoiteDeRéception (SUJET,TO,ENVOYELE,RECULE,Body,Size,CC,CCi,De,Attachments) VALUES ('" _
& IIf(Not IsNull(nouvsujet), nouvsujet, "") & "'" _
& ",'" & IIf(Not IsNull(objOLfolder.Items(I).TO), objOLfolder.Items(I).TO, "") & "'" _
& ",'" & IIf(Not IsNull(objOLfolder.Items(I).SentOn), objOLfolder.Items(I).SentOn, "") & "'" _
& ",'" & IIf(Not IsNull(objOLfolder.Items(I).ReceivedTime), objOLfolder.Items(I).ReceivedTime, "") & "'" _
& ",'" & IIf(Not IsNull(objOLfolder.Items(I).Body), objOLfolder.Items(I).Body, "") & "'" _
& ",'" & IIf(Not IsNull(objOLfolder.Items(I).Size), objOLfolder.Items(I).Size, "") & "'" _
& ",'" & IIf(Not IsNull(FchronoMesEmis(code)), FchronoMesEmis(code), "") & "'" _
& ",'" & IIf(Not IsNull(objOLfolder.Items(I).BCC), objOLfolder.Items(I).BCC, "") & "'" _
& ",'" & IIf(Not IsNull(objOLfolder.Items(I).SenderEmailAddress), objOLfolder.Items(I).SenderEmailAddress, "") & "'" _
& ",'" & IIf(Not IsNull(stPJointes), stPJointes, "") & "'" _
& ");"
DoCmd.RunSQL marequete
stPJointes = ""
Next I
'on réactive les avertissements
DoCmd.SetWarnings True
'fermeture des objets
'et libération
olkapp.Quit
Set olkapp = Nothing
'fermeture normale
Exit Sub
'en cas d'erreur
gere:
MsgBox ("L'erreur suivante a eu lieue : " & vbCrLf & Err.Description)
Exit Sub
End Sub
Partager