Consulting

Results 1 to 2 of 2

Thread: How to save emails from outlook from search folders to harddrive

  1. #1

    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. I want to automate this process. Currently the only option I have manually dragging the emails. Help is much appreciated. Thanks !

  2. #2
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •