Question

我正在尝试将选定的电子邮件保存在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

Answer 1

看起来您需要遍历资源管理器窗口中的所有选定项目，并使用txt文件格式保存每个项目。请注意，Selection对象可能包含各种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

您可以根据需要添加代码中显示的SaveAs语句。

Answer 2

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

 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

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

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

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

将所有选定的邮件保存到文本文件中：

注意：点击工具 - ＆gt;参考文献 - ＆gt;在使用此代码之前，请选中Microsoft Scripting Runtime框。

所选电子邮件将保存到用户的标准文档文件夹中，并带有日期和时间戳

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

参考：Save email message as text file

Answer 4

她是一个较短的解决方案，我提出的只是保存信息正文。

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

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

4 个答案: