Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
   Dim objItem As Object
   Dim sPath As String
   Dim dtDate As Date
   Dim sName As String
   Dim sNameSiemens As String
   Dim enviro As String

     enviro = CStr(Environ("USERPROFILE"))
    For Each objItem In ActiveExplorer.Selection
    If objItem.MessageClass = "IPM.Note" Then
     Set oMail = objItem

   'sName = oMail.Subject ' Place email subject in sName Only Object will be use to name the file
   sName = oMail.Subject & " From " & oMail.SenderName ' & "-" & oMail.To ' Place sender and receiver names in sName
   ReplaceCharsForFileName sName, "" ' Remove unalowed caracters from object in title.
   'sName = Left(sName, InStr(1, sName, " (") - 1) ' Remove Siemens unessessary name attributes
   RemoveSiemensCharsForFileName sName, "" ' Remove redundant project names from object in title.
   'ChangeInvoiceCharsForFileName sName, "Invoice" ' Remove "'Siemens Canada" from "'Siemens Canada Invoice" mail

   dtDate = oMail.ReceivedTime
   sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
     vbUseSystem) & Format(dtDate, " hhnn", _
     vbUseSystemDayOfWeek, vbUseSystem) & " " & sName & ".msg"
     'sPath = enviro & "\Desktop\emails\" ' Will save email on desktop "EMAILS" folder
     sPath = "C:\OneDrive - Siemens AG\Bureau\emails\" ' Will save email on OneDrive desktop "EMAILS" folder
   Debug.Print sPath & sName
   oMail.SaveAs sPath & sName, olMSG

   oMail.Delete ' Delete from mail folder and place it in deleted Outlook folder
   
   End If
   Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
   sName = Replace(sName, "'", sChr)
   sName = Replace(sName, "*", sChr)
   sName = Replace(sName, "/", sChr)
   sName = Replace(sName, "\", sChr)
   sName = Replace(sName, ":", sChr)
   sName = Replace(sName, "?", sChr)
   sName = Replace(sName, Chr(34), sChr)
   sName = Replace(sName, "<", sChr)
   sName = Replace(sName, ">", sChr)
   sName = Replace(sName, "|", sChr)
   sName = Replace(sName, ",", sChr)
   sName = Replace(sName, "[External] ", sChr)
   sName = Replace(sName, "  ", " ") 'Remove double space caracters
End Sub
Private Sub RemoveSiemensCharsForFileName(sName As String, sChr As String)
   'string.trimEnd
   sName = Replace(sName, ".pdf", sChr) 'Remove ".pdf"
   sName = Replace(sName, " SI RSS RAM BE SOL No Reply", sChr) 'SI RSS RAM BE SOL No Reply
   sName = Replace(sName, " (GBS ENG IN GPX BT Z8)", sChr) 'G Damodaran (GBS ENG IN GPX BT Z8)
   sName = Replace(sName, " (GBS O2C I2C CA)", sChr) 'Letourneau Marie Lise (GBS O2C I2C CA)
   sName = Replace(sName, " (GBS O2C I2C CA SI)", sChr) 'LETOURNEAU MARIE LISE (GBS O2C I2C CA SI)
   sName = Replace(sName, " (LC RC-CA OC)", sChr) 'BASHIR Sarah (LC RC-CA OC)
   sName = Replace(sName, " (RC-CA DI S-QC)", sChr) 'Gervais Martin (RC-CA DI S-QC)
   sName = Replace(sName, " (RC-CA SI EP FIN P)", sChr) 'Ballance Marie (RC-CA SI EP FIN P)
   sName = Replace(sName, " (RC-CA SI RAM)", sChr) 'Lukacko Peter (RC-CA SI RAM)
   sName = Replace(sName, " (RC-CA SI RAM BE)", sChr) 'Vlad Dragos (RC-CA SI RAM BE)
   sName = Replace(sName, " (RC-CA SI RAM BE QM)", sChr) 'CAI YING (RC-CA SI RAM BE QM)
   sName = Replace(sName, " (RC-CA SI RAM FIN)", sChr) 'KIHAL MUSTAPHA CHARIF (RC-CA SI RAM FIN)
   sName = Replace(sName, " (RC-CA SI RAM FIN BIL)", sChr) 'YAGHI Ghada Yaghi (RC-CA SI RAM FIN BIL)
   sName = Replace(sName, " (RC-CA SI RAM FIN E)", sChr) 'KIHAL MUSTAPHA CHARIF (RC-CA SI RAM FIN E)
   sName = Replace(sName, " (RC-CA SI RAM FIN LOG WH)", sChr) 'PAQUET ALAIN (RC-CA SI RAM FIN LOG WH)
   sName = Replace(sName, " (RC-CA SI RAM FIN OPS)", sChr) 'CALABRO SUZANNE (RC-CA SI RAM FIN OPS)
   sName = Replace(sName, " (RC-CA SI RAM FIN P)", sChr) 'FOURNIER CHRISTIAN (RC-CA SI RAM FIN P)
   sName = Replace(sName, " (RC-CA SI RAM FIN P OM)", sChr) 'LAPIERRE DANIEL (RC-CA SI RAM FIN P OM)
   sName = Replace(sName, " (RC-CA SI RAM FIN P SPR)", sChr) 'Fournier Christian (RC-CA SI RAM FIN P SPR)
   sName = Replace(sName, " (RC-CA SI RAM MON)", sChr) 'BIZIER RICHARD (RC-CA SI RAM MON)
   sName = Replace(sName, " (RC-CA SI RAM MON FS CSM)", sChr) 'COTE MICHEL (RC-CA SI RAM MON FS CSM)
   sName = Replace(sName, " (RC-CA SI RAM MON FS QUE2)", sChr) 'LAUZON BENOIT (RC-CA SI RAM MON FS QUE2)
   sName = Replace(sName, " (RC-CA SI RAM MON S)", sChr) 'Bizier Richard (RC-CA SI RAM MON S)
   sName = Replace(sName, " (RC-CA SI RAM MON S-AUTO)", sChr) 'DOUCET JOANNIE (RC-CA SI RAM MON S-AUTO)
   sName = Replace(sName, " (RC-CA SI RAM MON S-FSS)", sChr) ' JOMPHE SYLVAIN (RC-CA SI RAM MON S-FSS)
   sName = Replace(sName, " (RC-CA SI RAM MON S-QUE)", sChr) ' PELLETIER AMELIE (RC-CA SI RAM MON S-QUE)
   sName = Replace(sName, " (RC-CA SI RAM MON SES)", sChr) 'Voyer Mathieu (RC-CA SI RAM MON SES)
   sName = Replace(sName, " (RC-CA SI RAM NOC OPS-ENG)", sChr) 'Martel Benoit (RC-CA SI RAM NOC OPS-ENG)
   sName = Replace(sName, " (RC-CA SI RAM NOC OPS ENG-MON)", sChr) 'Martel Benoit (RC-CA SI RAM NOC OPS ENG-MON)
   sName = Replace(sName, " (RC-CA SI RAM NOC OPS ENG-TOR1)", sChr) 'Shen Jiayi (RC-CA SI RAM NOC OPS ENG-TOR1)
   sName = Replace(sName, " (RC-CA SI RAM SER CS2 D)", sChr) 'Vachon, Sylvie (RC-CA SI RAM SER CS2 D)
   sName = Replace(sName, " (RC-CA SI RAM SER DS)", sChr) 'Mallette Richard (RC-CA SI RAM SER DS)
   sName = Replace(sName, " (RC-CA SI RAM SER MON-FS)", sChr) 'Dupont Stephane (RC-CA SI RAM SER MON-FS)
   sName = Replace(sName, " (RC-CA SI RAM SER MON-FS QUE1)", sChr) 'Vermette Claude (RC-CA SI RAM SER MON-FS QUE1)
   sName = Replace(sName, " (RC-CA SI RAM SER MON-FS QUE2)", sChr) 'CORMIER MIKAEL (RC-CA SI RAM SER MON-FS QUE2)
   sName = Replace(sName, " (RC-CA SI RAM SER MON-FS SES)", sChr) 'Jasmin Pierre (RC-CA SI RAM SER MON-FS SES)
   sName = Replace(sName, " (RC-CA SI RAM SOL)", sChr) 'Tomasi Dino (RC-CA SI RAM SOL)
   sName = Replace(sName, " (RC-CA SI RAM SOL MON)", sChr) 'MORIN EMMANUEL (RC-CA SI RAM SOL MON)
   sName = Replace(sName, " (RC-CA SI RAM SOL MON FIR)", sChr) 'TAILLON RENE (RC-CA SI RAM SOL MON FIR)
   sName = Replace(sName, " (RC-CA SI RAM SOL MON FS)", sChr) 'LAFRENIERE MARIO (RC-CA SI RAM SOL MON FS)
   sName = Replace(sName, " (RC-CA SI RAM SOL MON QUE1)", sChr) 'Martel Carol (RC-CA SI RAM SOL MON QUE1)
   sName = Replace(sName, " (RC-CA SI RAM SOL MON QUE1 FSE)", sChr) 'BLAIS MICHEL (RC-CA SI RAM SOL MON QUE1 FSE)
   sName = Replace(sName, " (RC-CA SI RAM SOL MON QUE2)", sChr) 'JASMIN PIERRE (RC-CA SI RAM SOL MON QUE2)
   sName = Replace(sName, " (RC-CA SI RAM SOL PC)", sChr) 'Beaumont Manon (RC-CA SI RAM SOL PC)
   sName = Replace(sName, " (RC-CA SI RAM SOL ZIN1)", sChr) 'Benisse Mohamed Taib (RC-CA SI RAM SOL ZIN1)
   sName = Replace(sName, " (RC-CA SI RAM SOL ZTC M-DES)", sChr) 'HOUDE STEVEN (RC-CA SI RAM SOL ZTC M-DES)
   sName = Replace(sName, " (RC-CA SI RAM SOL ZTC T1-DES)", sChr) 'Houde Steven (RC-CA SI RAM SOL ZTC T1-DES)
   sName = Replace(sName, " (RC-CA SI RAM SOL ZTC ZIN1)", sChr) 'NISOT FREDERIC (RC-CA SI RAM SOL ZTC ZIN1)
   sName = Replace(sName, " (RC-CA SI RAM TOR FS)", sChr) 'PARE JEAN (RC-CA SI RAM TOR FS)
   'Palais de Justice de Roberval ---------------------------------------------------
   sName = Replace(sName, " CMiC IO", sChr) 'CMiC IO Pomerleau
   sName = Replace(sName, "17.0470AEM ", sChr) 'Palais Justice de Roberval
   sName = Replace(sName, "PJRob ", sChr) 'Palais Justice de Roberval
   '---------------------------------------------------------------------------------
   'sName = Replace(sName, " ", sChr) '
   'sName = Replace(sName, " ", sChr) '
End Sub

Private Sub ChangeInvoiceCharsForFileName(sName As String, sChr As String)
   sName = Replace(sName, "Siemens Canada Invoice", sChr) 'Remove "Siemens Canada"
End Sub