Save Selected Email Message as .msg File - digitally sign email doesn't works

E

EmmanuelMorin

Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
Hi, I use the @Diane Poremsky macro for years! It save me so much time during my work. Thanks Diane.

One thing that I'm unable to solve is the "digitally signed" email. The ones with a medal icon.
The macro can't handle them, it stop and quit (without crashing outlook) and I don't know why?
The macro JUMP directlly to the "End If" at the command "If objItem.MessageClass = "IPM.Note" Then".

Can you help?
Thanks


Here the macro text :
-------------------------------------------------------------------------
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
 

Attachments

  • Code de la Macro SaveMessageAsMsg.txt
    7.7 KB · Views: 0
After more searches, it appear that the objItem.MessageClass is "IPM.Note.SMIME.MultipartSigned". That why the sub jump to the "End if". I have added an new if routine to manage the "IPM.Note.SMIME.MultipartSigned" emails and my problem is solved.
 
You must log in or register to reply here.
< Automatically delete email when a condition is met | Outlook macros no longer run until VB editor is opened >
Similar threads
Thread starter Title Forum Replies Date
E Outlook 365 Save Selected Email Message as .msg File - oMail.Delete not working when SEARCH Outlook VBA and Custom Forms 0
N Save Selected Email Message as .msg File Outlook VBA and Custom Forms 12
Diane Poremsky Save Selected Email Message as .msg File Using Outlook 11
M Save selected email message as .msg file (with user to choose folder location) Outlook VBA and Custom Forms 14
G VBA to save selected Outlook msg with new name in selected network Windows folder Outlook VBA and Custom Forms 1
N Save selected messages VBA does not save replies and/or messages that contain : in subject Outlook VBA and Custom Forms 1
Rob Can't save MailItem because the message changed in .pst file Outlook VBA and Custom Forms 0
G Save emails as msg file from Outlook Web AddIn (Office JS) Outlook VBA and Custom Forms 0
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
C Outlook 365 Copy/Save Emails in Folder Outside Outlook to Show Date Sender Recipient Subject in Header Using Outlook 0
W Create a Quick Step or VBA to SAVE AS PDF in G:|Data|Client File Outlook VBA and Custom Forms 1
C Outlook (desktop app for Microsoft365) restarts every time I save my VBA? Using Outlook 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
N VBA Macro To Save Emails Outlook VBA and Custom Forms 1
N Save emails within a certain date range to network drive Outlook VBA and Custom Forms 0
T Outlook 365 Move newly created tasks automatically on save. Outlook VBA and Custom Forms 1
G Save attachment run a script rule Outlook VBA and Custom Forms 0
G Save and Rename Outlook Email Attachments Outlook VBA and Custom Forms 0
D Outlook 2016 64bit, Cannot Save in 'HTML', format Using Outlook 1
L Macro to add Date & Time etc to "drag to save" e-mails Outlook VBA and Custom Forms 17
S save attachment with date & time mentioned inside the file Outlook VBA and Custom Forms 0
S Add VBA save code Using Outlook 0
A Edit attachment Save and Reply Outlook VBA and Custom Forms 0
S Outlook (2016 32bit; Gmail IMAP) - Save sent message to Outllook Folder Outlook VBA and Custom Forms 0
P Outlook pst file is too huge with POP3. How to save more space? Using Outlook 4
D Prevent popup of "Do you want to save changes?" when closing after opening an appointment to view Outlook VBA and Custom Forms 2
A Unable to save recurring Meeting to Documents folder due to error Using Outlook 2
M Outlook 2013 Script Assistance - Save Opened Link with Subject Added Outlook VBA and Custom Forms 1
R Use an ItemAdd to Save Attachments on Arrival Outlook VBA and Custom Forms 0
W Outlook Calendar does not save view any longer! Using Outlook 3
S automate save the .xlxs file to share Network Using Outlook 1
S save email from excel Outlook VBA and Custom Forms 1
Y Open and Save Hyperlink Files in multiple emails Outlook VBA and Custom Forms 9
9 Outlook 2016 How to save an Outlook attachment to a specific folder then delete the email it came from? Using Outlook 1
O Save attachments using hotkey without changing attributes Outlook VBA and Custom Forms 1
geofferyh Cannot get Macro to SAVE more than one message attachment??? Outlook VBA and Custom Forms 5
N Open & Save VBAProject.Otm using VBA Code Outlook VBA and Custom Forms 1
R VBA | Chosing path to save file Outlook VBA and Custom Forms 1
W Save and rename outlook email attachments to include domain name & date received Outlook VBA and Custom Forms 4
V Change default default save location to Quick Access Using Outlook 1
W Save Outlook attachment in network folder and rename to current date and time Outlook VBA and Custom Forms 18
C Change default "Save Sent Item To" folder Outlook VBA and Custom Forms 9
C Outlook - cannot save subject line changes Using Outlook 2
J Save E-mail attachments in a specific folder Outlook VBA and Custom Forms 0
I Outlook 2016 64bit - on receipt convert emails into PDF and save Outlook VBA and Custom Forms 2
V VB script code to save a specific email attachment from a given email Outlook VBA and Custom Forms 14
C Auto save outlook attachments when email is received Outlook VBA and Custom Forms 1
N editing drafts - won't let me save Using Outlook 12
nathandavies Email Details to Excel & Save as .MSG on one macro - combination of 2 macros Outlook VBA and Custom Forms 3
C Need VBA code to automatically save message outside outlook and add date Outlook VBA and Custom Forms 1

Similar threads

Back
Top