1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
| Dim WithEvents colSentItems As Items
Private Sub Application_Startup()
'pour evenement itemadd
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Set colSentItems = NS.GetDefaultFolder(olFolderSentMail).Parent.Folders("test").Items 'dossier outlook où la macro va se déclancher
Set NS = Nothing
'fin section
End Sub
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
Dim myMail As Outlook.MailItem
Dim myMails As Outlook.Items
Dim filterStr As String
Dim test As String
If Item.Class = olMail Then
filterStr = "@SQL=""urn:schemas:httpmail:subject"" like '20%'"
Set myMails = colSentItems.Items.Restrict(filterStr)
MsgBox (myMails)
'répertoire où déplacer les mails
Repertoire = ("C:\Users\thibaud.veyssade\OneDrive - PBM\Bureau\testdes\mails\" & Item.Subject & "\")
'retirer les caractères interdits
Strname = Repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Item.Subject, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160)
'affiche l'objet du mail
MsgBox ("l'objet est " & Item.Subject)
Item.SaveAs Strname & ".msg", OlSaveAsType.olMSG
End If
End Sub |
Partager