Question

我将我的Outlook电子邮件归档到subfolders中。我想通过将它们保存到我的硬盘中来对其进行存档。我已经找到了行之有效的代码，但我想进行一次更改，但不知道该怎么做。

当前，我将消息名称另存为日期和时间，发件人以及主题。保存时，我想在文件名中添加subfolder名称。

我的代码如下。

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
  Dim sSender As String
  Dim sCategory As String

      enviro = CStr(Environ("USERPROFILE"))

  For Each objItem In ActiveExplorer.Selection
  If objItem.MessageClass = "IPM.Note" Then
   Set oMail = objItem

  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"

  sSender = oMail.SenderName

  sCategory = oMail.Categories

  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyy-mm-dd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "--hhnn", _
    vbUseSystemDayOfWeek, vbUseSystem) & " -- " & sCategory & " -- " & sSender & " -- " & sName & ".msg"

 sPath = enviro & "\Documents\Emails\"
   Debug.Print sPath & sName
   oMail.SaveAs sPath & sName, olMSG


  End If
  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, ":", 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 1

如果您已经拥有Outlook MailItem，则可以通过执行以下操作获取文件夹名称

FolderName = oMail.Parent.Name

这是因为Folder对象是Outlook对象模型中MailItem的父对象。

Answer 2

只需将 oMail.Parent.Name 添加到以下行

vbUseSystemDayOfWeek, vbUseSystem) & " -- " & sCategory & " -- " & sSender & " -- " & sName & ".msg"

示例

vbUseSystemDayOfWeek, vbUseSystem) & " -- " & sCategory & " -- " & sSender & " -- " & sName & " -- " & oMail.Parent.Name & ".msg"

See Folder.Name Property (Outlook) MSDN

Outlook VBA-将邮件保存到硬盘

2 个答案: