Solved: Simple move email to different folder

[gmayor]

I nearly didn't look at this thread. It is a six year old thread marked as 'solved'. You would have been better served creating a new thread. However

Option Explicit

Sub SaveMessages()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim fName As String
Dim fPath As String
fPath = "C:\Data\SR_PIXEL_Error_emails\"    'The folder to save the messages
    CreateFolders fPath 'Create the folder if it doesn't exist
    Set olFolder = Session.PickFolder
    Set olItems = olFolder.Items
    For Each olItem In olItems
        If olItem.Sender Like "*@somewhere.com" Then    'Replace with your domain
            fName = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                    Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
        Else
            fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.subject
        End If

        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
    Next olItem
    Set olItem = Nothing
    Set olItems = Nothing
    Set olFolder = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'An Office macro by Graham Mayor - www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not oFSO.FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFilename As String)
'An Outlook macro by Graham Mayor - www.gmayor.com
Dim lngF As Long
Dim lngName As Long
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    lngF = 1
    lngName = Len(strFilename)
    Do While fso.FileExists(strPath & strFilename & ".msg") = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFilename & ".msg"
lbl_Exit:
    Exit Function
End Function

[IonutC]

Hi Graham,

Thank you for your code.

How can i customize it to move into my folder from C ==> "C:\Data\SR_PIXEL_Error_emails" all my unread emails from the Outlook folder "2.3.1 ERROR: Pixel Comp - SR " that have the subject==> "Auto Error Notification for PIXEL Component: Service Request"?

Thank you in advance!

I really appreciate it,
Ionut