A macro that prompts for saving an email to the hard drive right after reading it

[dseeker]

My company's IT policy deletes emails every 90 days. Therefore, I am supposed to manually archive important emails that I want to keep.
This can be a pain as it sometimes slips my mind to do that within the 90 days. Therefore I need to create a macro that prompts me to save (or not) the email just after reading it to a specific folder on my PC.
This would be a super useful tool for me and for many other people who have the same problem I guess.
Any pointers are most appreciated. A

[jigar1276]

My company's IT policy deletes emails every 90 days. Therefore, I am supposed to manually archive important emails that I want to keep.
This can be a pain as it sometimes slips my mind to do that within the 90 days. Therefore I need to create a macro that prompts me to save (or not) the email just after reading it to a specific folder on my PC.
This would be a super useful tool for me and for many other people who have the same problem I guess.
Any pointers are most appreciated. A

Please try the bellow macro to start with. It will save all the emails which are selected in your outlook.


Sub SaveEmails()
Dim olitem As Object
Dim FSO As Object
Dim objSelection As Outlook.Selection
Dim path, fileNM As String
'//checking if emails are selected or not
Set objSelection = Application.ActiveExplorer.Selection
Set FSO = CreateObject("Scripting.FileSystemObject")

path = "D:\SavedEmails\" 'Write the path here where you want to save the emails. Make sure "\" is added at the end of path.

For Each olitem In Application.ActiveExplorer.Selection
fileNM = olitem.Subject & ".msg"
fileNM = Replace(fileNM, "/", "-")
fileNM = Replace(fileNM, "|", "-")
fileNM = Replace(fileNM, "<", "-")
fileNM = Replace(fileNM, ">", "-")
fileNM = Replace(fileNM, ":", "-")
fileNM = Replace(fileNM, "*", "-")
fileNM = Replace(fileNM, "?", "-")
fileNM = Replace(fileNM, "|", "-")
fileNM = Replace(fileNM, Chr(34), "")
olitem.SaveAs path & fileNM, olMSG
Next olitem

Set objSelection = Nothing
Set FSO = Nothing
Set olitem = Nothing
Set olattach = Nothing
End Sub