EmmanuelMorin
Member
- Outlook version
- Outlook 365 64 bit
- Email Account
- Office 365 Exchange
On Outlook 365 for Enterprise.
After I done SEARCH and found email that I want to save as .msg, the MACRO stop at the command "oMail.Delete".
Can you explain why ?
******************************************************************************
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
Dim Message_Classes As String
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
Message_Classes = objItem.MessageClass ' For DEBUG purpose only. To know what it the class of the selected objects.
' [MS-ASEMAIL]: MessageClass
' Pour email normal --------------------------------------------------------------------------
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject & " From " & oMail.SenderName ' & "-" & oMail.To ' Place sender and receiver names in sName
ReplaceCharsForFileName sName, "" ' Remove unalowed caracters from object in title.
RemoveSiemensCharsForFileName sName, "" ' Remove redundant project names from object in title.
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
Else
' Pour email DIGITALY SIGN (The message is clear signed) ---------------------------------------
If objItem.MessageClass = "IPM.Note.SMIME.MultipartSigned" Then
Set oMail = objItem
sName = oMail.Subject & " From " & oMail.SenderName ' & "-" & oMail.To ' Place sender and receiver names in sName
ReplaceCharsForFileName sName, "" ' Remove unalowed caracters from object in title.
RemoveSiemensCharsForFileName sName, "" ' Remove redundant project names from object in title.
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
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, "[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
End Sub
After I done SEARCH and found email that I want to save as .msg, the MACRO stop at the command "oMail.Delete".
Can you explain why ?
******************************************************************************
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
Dim Message_Classes As String
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
Message_Classes = objItem.MessageClass ' For DEBUG purpose only. To know what it the class of the selected objects.
' [MS-ASEMAIL]: MessageClass
' Pour email normal --------------------------------------------------------------------------
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject & " From " & oMail.SenderName ' & "-" & oMail.To ' Place sender and receiver names in sName
ReplaceCharsForFileName sName, "" ' Remove unalowed caracters from object in title.
RemoveSiemensCharsForFileName sName, "" ' Remove redundant project names from object in title.
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
Else
' Pour email DIGITALY SIGN (The message is clear signed) ---------------------------------------
If objItem.MessageClass = "IPM.Note.SMIME.MultipartSigned" Then
Set oMail = objItem
sName = oMail.Subject & " From " & oMail.SenderName ' & "-" & oMail.To ' Place sender and receiver names in sName
ReplaceCharsForFileName sName, "" ' Remove unalowed caracters from object in title.
RemoveSiemensCharsForFileName sName, "" ' Remove redundant project names from object in title.
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
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, "[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
End Sub