Forum Clubic

[OUTLOOK] Enregistrer les messages

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é