save text in email to a file on the PC

[lvas12]

I need to open emails in a certain folder and save the text in the emails to a file.

 

[ttmac]

The following code will step through all the mail messages in the folder "Deleted Items" and will write the body of the message to a file which is named from the subject.

Sub Open_MailItems_and_Save()

    Dim OLF As Outlook.MAPIFolder
    Dim CurrUser As String
    Dim EmailItemCount As Integer
    Dim i As Integer
    Dim EmailCount As Integer
    Dim fs, f, ts, s
    Dim myFileName As String
    Dim myPath As String
    
    Const ForReading = 1
    Const ForWriting = 2
    Const ForAppending = 3
    
    Const TristateUseDefault = -2
    Const TristateTrue = -1
    Const TristateFalse = 0
        
        '''''''''''''''''''''''''''''''
        ' Set File Save Path as c:\temp
        
        myPath = "C:\Temp\"
        
        '''''''''''''''''''''''''''''''
        ' Get required mailbox folder
        
        
        Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Deleted Items")
        
        '''''''''''''''''''''''''''''''
        ' get count of mail items
        
        EmailItemCount = OLF.Items.Count
        i = 0
        EmailCount = 0
        
        
        '''''''''''''''''''''''''''''''
        ' loop through all emails in folder
        
        While i < EmailItemCount
            i = i + 1
        
            '''''''''''''''''''''''''''''''
            ' with each mail item
                
            With OLF.Items(i)
            
                EmailCount = EmailCount + 1 'increment counter
                
                
                '''''''''''''''''''''''''''''''
                ' Create the text file name and path
                ' using the file system object.  File
                ' called after first 8 characters of subject
                
        
                Set fs = CreateObject(&quot;Scripting.FileSystemObject&quot;)
                myFileName = myPath & Trim(Left(.Subject, 8)) & &quot;.txt&quot;
                fs.CreateTextFile myFileName           'Create a file
                Set f = fs.GetFile(myFileName)
                Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault) 'Open the file
                ts.Write .Body       ' write mail message to file
                ts.Close             ' and close
        
            End With
        Wend
        
        Set OLF = Nothing
    
End Sub

Hope it helps.