Hey everyone just need help on how to save emails from outlook from search folders to harddrive. I want to automate this process. Currently the only option I have manually dragging the emails. Help is much appreciated. Thanks !
Hey everyone just need help on how to save emails from outlook from search folders to harddrive. I want to automate this process. Currently the only option I have manually dragging the emails. Help is much appreciated. Thanks !
You can do this with the aid of a couple of macros (below). Change the line
Const fPath As String = "C:\Path\" 'The path where you want to save the messages
to reflect AN EXISTING folder in which to save the messages. Select a message or a number of messages and run the macro 'SaveSelected'.
If you wished you could apply the macro 'SaveMessage' as a script attached to a rule to process the messages as they arrive in the inbox.
Sub SaveSelected() Dim olItem As MailItem For Each olItem In Application.ActiveExplorer.Selection If olItem.Class = OlObjectClass.olMail Then SaveMessage olItem End If Next olItem Set olItem = Nothing End Sub Sub SaveMessage(olItem As MailItem) Dim Fname As String Const fPath As String = "C:\Path\" 'The path where you want to save the messages Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _ Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject Fname = Replace(Fname, Chr(58) & Chr(41), "") Fname = Replace(Fname, Chr(58) & Chr(40), "") Fname = Replace(Fname, Chr(34), "-") Fname = Replace(Fname, Chr(42), "-") Fname = Replace(Fname, Chr(47), "-") Fname = Replace(Fname, Chr(58), "-") Fname = Replace(Fname, Chr(60), "-") Fname = Replace(Fname, Chr(62), "-") Fname = Replace(Fname, Chr(63), "-") Fname = Replace(Fname, Chr(124), "-") SaveUnique olItem, fPath, Fname End Sub Private Function SaveUnique(oItem As Object, _ strPath As String, _ strFilename As String) Dim lngF As Long Dim lngName As Long lngF = 1 lngName = Len(strFilename) Do While FileExists(strPath & strFilename & ".msg") = True strFilename = Left(strFilename, lngName) & "(" & lngF & ")" lngF = lngF + 1 Loop oItem.SaveAs strPath & strFilename & ".msg" End Function
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com