使用Outlook VBA将所选电子邮件另存为文本文件

我正在尝试将Outlook中选定的电子邮件保存为文本文件

我希望它能像这样工作：

一次保存一封电子邮件，但保存所有选定的电子邮件，而不仅仅是一封电子邮件

它们都需要保存为新文件。我知道导出功能将它们保存为一个大文本文件，但需要每个文件都有自己的文件

以下是我目前掌握的情况：

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

---

将单个选定邮件保存到文本文件：

选定的电子邮件将以代码中指定的路径保存到文本文件中

---

参考：

看起来您需要在资源管理器窗口中迭代所有选定的项目，并使用txt文件格式保存每个项目。请注意，选择对象可能包含各种Outlook项目类型。下面的代码显示了对所有选定项进行迭代并检测该项的步骤：

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

---

您可以在需要时添加代码中显示的语句

谢谢大家的帮助。我找到了答案。下面是对我有用的东西

 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

Sub SaveSelectedMailAsTxtFile（）
常数OLTXT=0
将currentExplorer设置为资源管理器
将选择变暗作为选择
将oMail设置为Outlook.MailItem
作为对象的Dim obj
像细绳一样暗淡
Dim dtDate作为日期
像绳子一样模糊
设置currentExplorer=Application.ActiveExplorer
Set Selection=currentExplorer.Selection
对于选择中的每个obj
设置oMail=obj
sName=oMail.Subject
替换CharsforFileName sName，“\u”
dtDate=oMail.ReceivedTime
sName=格式（dtDate，“yyyymmdd”，vbUseSystemDayOfWeek_
vbUseSystem）和格式（dtDate，“-hhnss”_
vbUseSystemDayOfWeek，vbUseSystem）和“-”以及sName和“.txt”
oMail.SaveAs“C:\my\path\”和sName，OLTXT
下一个
端接头
Private Sub-ReplaceCharsForFileName（sName作为字符串_
弦_
)
sName=替换（sName，“/”，sChr）
sName=替换（sName，\，sChr）
sName=替换（sName，“：”，sChr）
sName=替换（sName，“？”，sChr）
sName=替换（sName，Chr（34），sChr）
sName=替换（sName，“，sChr）
sName=替换（sName，“|”，sChr）
端接头

她的解决方案是我提出的一个较短的解决方案，它只保存了邮件的正文

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

Sub-selectToText（）
将Omail设置为Outlook.MailItem
设置Omail=Application.ActiveExplorer.Selection.Item（1）所选消息
将主题设置为字符串：subject=Omail.subject'获取主题
将rmv设置为变量：rmv=Array（“\”、“/”、“：”、“*”、“？”、“、”、“|”）文件名的无效字符
Dim r作为变量“保存字符”
Dim txtFile As String'保存要保存到的目录
对于rmv'中的每个r，删除无效字符
主题=替换（主题，r，“”）
下一个r
txtFile=“C:\”&subject&“.txt”将保存位置设置为要保存的位置！
打开txtFile，输出为#1
写入#1，Omail.Body'写入电子邮件正文以保存位置
关闭#1
端接头

您可能应该问一个实际的问题，并强调哪些代码不适用。考虑一下你尝试过的那些不起作用的东西。这只是保存一个来自Explorer中的选择的电子邮件，而不是所有被选中的邮件。我删除了DePaseFipe并用保存消息替换了它。但是，我收到一个错误，说我无法写入文件并检查我对文件夹的权限。C:驱动器需要管理员权限才能写入。选择其他驱动器/文件夹或以管理员身份运行Outlook（提升）。在使用其属性之前，您确实应该检查

选择中的
obj
是否是电子邮件
（obj.Class=olMail）
。
 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

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