PDA

View Full Version : How to save emails from outlook from search folders to harddrive



hawan1823
10-15-2014, 06:46 AM
Hey everyone just need help on how to save emails from outlook from search folders to harddrive. :crying: I want to automate this process. Currently the only option I have manually dragging the emails. Help is much appreciated. Thanks !

gmayor
10-15-2014, 07:35 AM
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