Bonjour
Suite à un plantage de ma messagerie sous outlook, j’ai perdu 15 jours de messagerie.
J’aimerais pouvoir enregistrer les messages automatiquement en tant que fichier .msg.
Vous me direz, rien de plus facile :na:
Mais ma problématique est de classer les messages pour pouvoir les retrouver.
Donc j’aimerais les enregistrer avec un implementation du type
“nomexpediteur - datemessage”.msg
Est ce que quelqu’un peut me dire quels sont les parametres dans VBA pour retrouver l’adresse de l’expediteur et la date d’envoi.
Merci d’avance
Voici un petite programme que j’ai fait pour mon entreprise.
Je pense que c’est ce que tu cherches.
Sub Move_to_archive3()
'--------------------------- Version du 10-01-2005 ---------------------------------------------
'— Sauvergarde les mails sans demander de chemin ( dans U:\Mails ) ---------------------------
'— Test OK -----------------------------------------------------------------------------------
Dim myOlApp As Outlook.Application
Dim myOlExp As Explorer
Dim myOlSel As Outlook.Selection
Dim FileSaveName As String
Dim myMail
Dim Date_Mail As Date
Dim Chemin As String
Dim Nom_Mail As String
Dim Annee As String
Dim Mois As String
Dim Jour As String
Dim Reponse As Integer
Dim ProcID As Long
Dim Titre As String
Dim Corps As String
Dim Titre2 As String
Dim Corps2 As String
Dim Langue As Integer
On Error GoTo Tr_Erreur
Set myOlApp = CreateObject("Outlook.Application")
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
Nom_Mail = myOlSel.Item(1).SenderName
Langue = ThisOutlookSession.LanguageSettings.LanguageID(msoLanguageIDUI)
Select Case Langue
Case 1036
Titre = "Remplacer fichier... "
Corps = "Un fichier du même nom exite déjà !" & Chr(13) _
& "Voulez-vous le remplacer ?"
Corps2 = "Veuillez sélectionner un mail !"
Titre2 = "Attention..."
Case 1031
Titre = "File überschreiben "
Corps = "Ein File mit dem selben Namen existiert bereits !" & Chr(13) _
& "Wollen Sie es ersetzen ?"
Corps2 = "Veuillez sélectionner un mail !"
Titre2 = "Attention..."
Case 1040
Titre = "Attenzione..."
Corps = "Un file con questo nome e gia presente !" & Chr(13) _
& "Voule sostituire il file ?"
Corps2 = "Veuillez sélectionner un mail !"
Titre2 = "Attention..."
Case Else
Titre = "Remplacer fichier"
Corps = "Un fichier du même nom exite déjà !" & Chr(13) _
& "Voulez-vous le remplacer ?"
Corps2 = "Veuillez sélectionner un mail !"
Titre2 = "Attention..."
End Select
Chemin = "U:\Mails\"
For Each myMail In myOlSel
Nom_Mail = myMail.SenderName & "-" & myMail.Subject
Date_Mail = myMail.ReceivedTime
Annee = Mid(Date_Mail, 9, 2)
Mois = Mid(Date_Mail, 4, 2)
Jour = Mid(Date_Mail, 1, 2)
Nom_Mail = "Email " & Annee & "-" & Mois & "-" & Jour & " " & Nom_Mail
Nom_Mail = Replace(Nom_Mail, ":", "")
Nom_Mail = Replace(Nom_Mail, "/", " ")
Nom_Mail = Replace(Nom_Mail, "\", " ")
Nom_Mail = Replace(Nom_Mail, "?", " ")
Nom_Mail = Replace(Nom_Mail, "*", " ")
Nom_Mail = Replace(Nom_Mail, "<", " ")
Nom_Mail = Replace(Nom_Mail, ">", " ")
Nom_Mail = Replace(Nom_Mail, ".", " ")
Nom_Mail = Replace(Nom_Mail, Chr(34), " ")
FileSaveName = Chemin & Nom_Mail & ".msg"
If Len(FileSaveName) > 2 Then
On Error GoTo Tr_Erreur_Ordner
myMail.To = " "
myMail.CC = " "
myMail.BCC = " "
myMail.SentOnBehalfOfName = ""
myMail.SaveAs FileSaveName, olMSG
myMail.Delete
End If
Next
Exit Sub
Tr_Erreur_Ordner:
MkDir (Chemin)
Resume
Tr_Erreur:
MsgBox Corps2, vbExclamation, Titre2
End Sub
merci à toi
Après un premier survol du code il semblerait que ce soit exactement ce que je recherche
je vais tester et modifier pour obtenir le resultat souhaité