Styjun

I have been working with this code. I need to take just the body from a new email and place it in a text file. I'm filtering by subject and moving it to a sub folder. I didn't write most of this code and have been trying to get a better understanding of it.

I can't determine what part of the script controls that. I don't need any other part of the email.

 Option Explicit
 Private WithEvents Items As Outlook.Items
 Private Sub Application_Startup()
 Dim olNs As Outlook.NameSpace
 Dim Inbox As Outlook.MAPIFolder

 Set olNs = Application.GetNamespace("MAPI")
 Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
 Set Items = Inbox.Items
 End Sub

 Private Sub Items_ItemAdd(ByVal Item As Object)
 If TypeOf Item Is Outlook.MailItem Then
 SaveMailAsFile Item ' call sub
 End If
 End Sub
 Public Sub SaveMailAsFile(ByVal Item As Object)
 Dim olNs As Outlook.NameSpace
 Dim Inbox As Outlook.MAPIFolder
 Dim SubFolder As Outlook.MAPIFolder
 Dim Items As Outlook.Items
 Dim ItemSubject As String
 Dim NewName As String
 Dim RevdDate As Date
 Dim Path As String
 Dim Ext As String
 Dim i As Long

 Set olNs = Application.GetNamespace("MAPI")
 Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
 Set Items = Inbox.Items.Restrict("[Subject] = 'Auto~! Keep ad the same'")

 Path = Environ("USERPROFILE") & "DesktopTemp"
 ItemSubject = Item.Subject
 RevdDate = Item.ReceivedTime
 Ext = "txt"

 For i = Items.Count To 1 Step -1
 Set Item = Items.Item(i)

 DoEvents

 If Item.Class = olMail Then
 Debug.Print Item.Subject ' Immediate Window
 Set SubFolder = Inbox.Folders("SSX") ' <--- Update Fldr Name

 ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
 & " - " & _
 Item.Subject & Ext

 ItemSubject = FileNameUnique(Path, ItemSubject, Ext)

 Item.SaveAs Path & ItemSubject, olTXT
 Item.Move SubFolder
 End If
 Next

 Set olNs = Nothing
 Set Inbox = Nothing
 Set SubFolder = Nothing
 Set Items = Nothing

 End Sub


 '// Check if the file exists
 Private Function FileExists(FullName As String) As Boolean
 Dim fso As Object
 Set fso = CreateObject("Scripting.FileSystemObject")

 If fso.FileExists(FullName) Then
 FileExists = True
 Else
 FileExists = False
 End If

 Exit Function
 End Function

 '// If the same file name exist then add (1)
 Private Function FileNameUnique(Path As String, _
 FileName As String, _
 Ext As String) As String
 Dim lngF As Long
 Dim lngName As Long
 lngF = 1
 lngName = Len(FileName) - (Len(Ext) + 1)
 FileName = Left(FileName, lngName)

 Do While FileExists(Path & FileName & Chr(46) & Ext) = True
 FileName = Left(FileName, lngName) & " (" & lngF & ")"
 lngF = lngF + 1
 Loop

 FileNameUnique = FileName & Chr(46) & Ext

 Exit Function
 End Function

Quick example here

Option Explicit
Private Sub Example()
 Dim FSO As New FileSystemObject
 Dim TS As TextStream
 Dim olMsg As Outlook.MailItem

 Set olMsg = ActiveExplorer.selection.Item(1)
 Set TS = FSO.OpenTextFile("C:TempEmail.txt", ForAppending, True)
 TS.Write (olMsg.Body)
 TS.Close

End Sub