How to save emails from outlook from search folders to harddrive

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 !

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.

Code:

---

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

---