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

Question

I am trying to save selected emails in Outlook as Text files.

I would like it to work like this:

1. Saves one email at a time but saves all selected emails instead of just a single email.

2. 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

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

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

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.