Using Outlook VBA to save selected email(s) as a text file - vba

Question

I am trying to save selected emails in Outlook as Text files.
I would like it to work like this:
Saves one email at a time but saves all selected emails instead of just a single email.
They need to each be saved as a new file. I know that the export feature saves them all as one large text file, but need them to each have their own.
Here's what I have so far:
Sub SaveEmail()
Dim Msg As Outlook.MailItem
' assume an email is selected
Set Msg = ActiveExplorer.Selection.item(2)
' save as text
Msg.SaveAs "C:\My Location", OLTXT
End Sub

Answer 1

It looks like you need to iterate over all selected items in the explorer window and save each one using the txt file format. Be aware, the Selection object may contain various Outlook item types. The following code showshow to iterate over all items selected and detect what item is:
Private Sub GetSelectedItem_Click()
' This uses an existing instance if available (default Outlook behavior).
' Dim oApp As New Outlook.Application - for running in external applications
Dim oExp As Outlook.Explorer
Dim oSel As Outlook.Selection ' You need a selection object for getting the selection.
Dim oItem As Object ' You don't know the type yet.
Set oExp = Application.ActiveExplorer ' Get the ActiveExplorer.
Set oSel = oExp.Selection ' Get the selection.
For i = 1 To oSel.Count ' Loop through all the currently .selected items
Set oItem = oSel.Item(i) ' Get a selected item.
DisplayInfo oItem ' Display information about it.
Next i
End Sub
Sub DisplayInfo(oItem As Object)
Dim strMessageClass As String
Dim oAppointItem As Outlook.AppointmentItem
Dim oContactItem As Outlook.ContactItem
Dim oMailItem As Outlook.MailItem
Dim oJournalItem As Outlook.JournalItem
Dim oNoteItem As Outlook.NoteItem
Dim oTaskItem As Outlook.TaskItem
' You need the message class to determine the type.
strMessageClass = oItem.MessageClass
If (strMessageClass = "IPM.Appointment") Then ' Calendar Entry.
Set oAppointItem = oItem
MsgBox oAppointItem.Subject
MsgBox oAppointItem.Start
ElseIf (strMessageClass = "IPM.Contact") Then ' Contact Entry.
Set oContactItem = oItem
MsgBox oContactItem.FullName
MsgBox oContactItem.Email1Address
ElseIf (strMessageClass = "IPM.Note") Then ' Mail Entry.
Set oMailItem = oItem
MsgBox oMailItem.Subject
MsgBox oMailItem.Body
ElseIf (strMessageClass = "IPM.Activity") Then ' Journal Entry.
Set oJournalItem = oItem
MsgBox oJournalItem.Subject
MsgBox oJournalItem.Actions
ElseIf (strMessageClass = "IPM.StickyNote") Then ' Notes Entry.
Set oNoteItem = oItem
MsgBox oNoteItem.Subject
MsgBox oNoteItem.Body
ElseIf (strMessageClass = "IPM.Task") Then ' Tasks Entry.
Set oTaskItem = oItem
MsgBox oTaskItem.DueDate
MsgBox oTaskItem.PercentComplete
End If
End Sub
You can add the SaveAs statement shown in your code where required.

Answer 2

Thank you everybody for your help. I was able to find the answer. Below is what worked for me.
Sub SaveSelectedMailAsTxtFile()
Const OLTXT = 0
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set oMail = obj
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".txt"
oMail.SaveAs "C:\my\path\" & sName, OLTXT
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub

Answer 3

To save a single selected mail to a text file:
Selected email will be saved to a text file in the path specified in the code
Sub SaveMailAsFile()
Const OLTXT = 0
Dim oMail As Outlook.mailItem
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Set oMail = Application.ActiveExplorer.Selection.Item(1)
sName = oMail.Subject
ReplaceCharsForFileName sName, "_"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".txt"
oMail.SaveAs "C:\path\to\save\" & sName, OLTXT
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
To save all selected mails to a text file:
NOTE: Click on Tools -> References -> Check the box for Microsoft Scripting Runtime before using this code.
Selected email(s) will be save to the user's standard Documents folder with the date and time stamp
Sub MergeSelectedEmailsIntoTextFile()
Dim objFS As New Scripting.FileSystemObject, objFile As Scripting.TextStream
Dim objItem As Object, strFile As String
Dim Folder As Folder
Dim sName As String
' Use your User folder as the initial path
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
If ActiveExplorer.Selection.Count = 0 Then Exit Sub
' use the folder name in the filename
Set Folder = Application.ActiveExplorer.CurrentFolder
' add the current date to the filename
sName = Format(Now(), "yyyy-mm-dd-hh-MM-ss")
' The folder pathyou use needs to exist
strFile = enviro & "\Documents\" & sName & "-" & Folder & ".txt"
Set objFile = objFS.CreateTextFile(strFile, False)
If objFile Is Nothing Then
MsgBox "Error creating file '" & strFile & "'.", vbOKOnly + vbExclamation _
, "Invalid File"
Exit Sub
End If
For Each objItem In ActiveExplorer.Selection
With objFile
.Write vbCrLf & "--Start--" & vbCrLf
.Write "Sender: " & objItem.Sender & " <" & objItem.SenderEmailAddress & ">" & vbCrLf
.Write "Recipients : " & objItem.To & vbCrLf
.Write "Received: " & objItem.ReceivedTime & vbCrLf
.Write "Subject: " & objItem.Subject & vbCrLf & vbCrLf
.Write objItem.Body
.Write vbCrLf & "--End--" & vbCrLf
End With
Next
objFile.Close
MsgBox "Email text extraction completed!", vbOKOnly + vbInformation, "DONE!"
Set objFS = Nothing
Set objFile = Nothing
Set objItem = Nothing
End Sub
Reference: Save email message as text file

Answer 4

Hers is a shorter Solution I came up with that just saves the body of the message.
Sub selectToText()
Dim Omail As Outlook.MailItem
Set Omail = Application.ActiveExplorer.Selection.Item(1)'Selected Message
Dim subject As String: subject = Omail.subject 'Get subject
Dim rmv As Variant: rmv = Array("\", "/", ":", "*", "?", """", "<", ">", "|") 'Invalid chars for a file name
Dim r As Variant 'holds a char
Dim txtFile As String 'holds dir to save to
For Each r In rmv ' remove invalid chars
subject = Replace(subject, r, "")
Next r
txtFile = "C:\" & subject & ".txt" 'set save to location CHANGE this to where you want to save!
Open txtFile For Output As #1
Write #1, Omail.Body 'write email body to save location
Close #1
End Sub