Joel asked

I get a lot of pictures from a photographer, he writes the details in the email body. Is there a way to save each email in a separate folder, the name should be the subject line? and the email body should be saved as a text file?

Sure, you can do this using VBA.

This macro creates a folder in your Documents folder using the subject name (after removing any illegal characters) and then saves the message (as HTML) and any attachments to the folder.

If you want the message saves as a text or doc file, change
objMsg.SaveAs strFolderpath & strName & ".htm", olHTML to
objMsg.SaveAs strFolderpath & strName & ".txt", olTXT or
objMsg.SaveAs strFolderpath & strName & ".rtf", olRTF

To save it as a message file, use
objMsg.SaveAs strFolderpath & strName & ".msg", olMsg

To use, select the message then run the macro.

Public Sub SaveMessagesAndAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strName As String
Dim strFolderpath As String
Dim strDeletedFiles As String
 Dim sFileType As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
    
Dim fso As Object
Dim oldName
    
Set fso = CreateObject("Scripting.FileSystemObject")
      
    On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)
 strName = StripIllegalChar(objMsg.Subject)
    
strFolderpath = enviro & "\Documents\" & strName & "\"
If Not fso.FolderExists(strFolderpath) Then
    fso.CreateFolder (strFolderpath)
End If

 objMsg.SaveAs strFolderpath & strName & ".htm", olHTML
 
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
         
    If lngCount > 0 Then
     
    For i = lngCount To 1 Step -1
     
    strFile = objAttachments.Item(i).FileName
    Debug.Print strFile
    strFile = strFolderpath & strFile
    objAttachments.Item(i).SaveAsFile strFile
   
    Next i
    End If
          
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Function StripIllegalChar(StrInput)
    Dim RegX            As Object    
    Set RegX = CreateObject("vbscript.regexp")
       
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
    RegX.IgnoreCase = True
    RegX.Global = True
       
    StripIllegalChar = RegX.Replace(StrInput, "")
       
ExitFunction:
    Set RegX = Nothing
       
End Function

Save Attachment to a Specific Folder

This version of the macro saves the attached images to a specific folder using a filename format that includes the date. I use this to save images from incoming email. If you want to save the files but don't want to rename them, remove the lines that change the oldName to the newname.

Select the message then run the macro.

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
 Dim sFileType As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
    
Dim fso As Object
Dim oldName
    
Set fso = CreateObject("Scripting.FileSystemObject")
      
    On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)
    
strFolderpath = enviro & "\Attachments\" '& Format(objMsg.SentOn, "yymd")
 
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
         
    If lngCount > 0 Then
     
    For i = lngCount To 1 Step -1
     
    strFile = objAttachments.Item(i).filename
    strFile = strFolderpath & strFile
    objAttachments.Item(i).SaveAsFile strFile
   
'Get the file name
 Set oldName = fso.GetFile(strFile)
 Debug.Print oldName
 sFileType = LCase$(Right$(oldName, 6))
 Debug.Print sFileType

 DateFormat = Format(objMsg.SentOn, "yymmdd-")
 newName = "RC" & DateFormat & sFileType
 Debug.Print newName
 oldName.Name = newName
 
    Next i
    End If
          
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub 

Save a Message and Attachments to a New Folder

This is the macro I use to save a message and it's attachments to a new folder named for the message subject. I shorten the subject to 40 characters to avoid problems with long file names.

To use, select one message and run the macro. If more than one message is selected, it runs only on the first message.

Public Sub SaveMessagesAndAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim StrFile As String
Dim StrName As String
Dim strTime 'As String
Dim StrFolderPath As String
    
Dim FSO As Object
Dim oldName
    
Set FSO = CreateObject("Scripting.FileSystemObject")
      
On Error Resume Next
Set objOL = Outlook.Application
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)

' remove illegal characters and shorten name
 StrName = StripIllegalChar(objMsg.Subject)
 StrName = Left(StrName, 40)
       
strTime = DateValue(objMsg.ReceivedTime) '& TimeValue(objMsg.ReceivedTime)

' I use this to reduce changes of duplicate names
strTime = Format(objMsg.ReceivedTime, "-hhmmss")
Debug.Print strTime
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    Debug.Print strFolderpath
    On Error Resume Next
StrFolderPath = StrFolderPath & "\Attachments\" & StrName & strTime & "\"

' create folder if doesn't exist
If Not FSO.FolderExists(StrFolderPath) Then
    FSO.CreateFolder (StrFolderPath)
End If

' Save message and as html and doc file type
 objMsg.SaveAs StrFolderPath & StrName & ".msg", olMsg
 objMsg.SaveAs StrFolderPath & StrName & ".doc", olRTF
 objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML
 
 'save any attachments also
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
         
    If lngCount > 0 Then
     
    For i = lngCount To 1 Step -1
     
    StrFile = objAttachments.Item(i).FileName
    Debug.Print StrFile
    StrFile = StrFolderPath & StrFile
    objAttachments.Item(i).SaveAsFile StrFile
   
    Next i
    End If
          
ExitSub:
 
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

How to use macros

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor