Outlook 2010 VBA 如何保存包含附件的邮件

Question

您好，我正在使用以下代码将邮件保存到文件夹，但是如果邮件有附件，则它不起作用。

我知道如果我手动将消息移动到硬盘驱动器，附件仍在 *.msg 文件中。

我认为这就是我在此特定部分中保存消息的方式

oMail.SaveAs sPath & sName, olMSG

如何更改以下代码以通过 VBA 执行此操作。

Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim sndName As String
  Dim enviro As String

    enviro = "c:\emails"
   For Each objItem In ActiveExplorer.Selection
   If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
  sndName = oMail.Sender
  ReplaceCharsForFileName sndName, "-"
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"

  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sndName & "-" & sName     & ".msg"

    sPath = enviro
  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

提前致谢

更新自己解决了

我现在已经自己解决了这些问题，您需要小心，因为这取决于收到的电子邮件是如何创建的。

如果电子邮件和主题特别是使用 excel 创建的，它将在其中包含制表符分隔符，这可能会导致上述代码失效。要解决此问题，请使用以下代码：

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 SndName As String
  Dim enviro As String


enviro = "c:\emails\" 'sets folder to save messgaes to

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

        sName = oMail.Subject
        SndName = oMail.SenderName
        dtDate = oMail.ReceivedTime

        ReplaceCharsForFileName sName, "-"

            sName = Right(sName, 100)
  'formats the file name as "Sender name - Date - Time - Subject"
                sName = SndName & " - " & Format(dtDate, "dd-mm-yy", vbUseSystemDayOfWeek, _
                vbUseSystem) & " - " & Format(dtDate, "hhnnss", _
                vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"

        sPath = enviro

        Debug.Print sPath & sName
        oMail.SaveAs sPath & sName, olMSG

    End If
  Next

End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)

'Replaces the invalid characters you could use RegX with vbscript instead

 sName = Replace(sName, "´", "'")
 sName = Replace(sName, "`", "'")
 sName = Replace(sName, "{", "(")
 sName = Replace(sName, "[", "(")
 sName = Replace(sName, "]", ")")
 sName = Replace(sName, "}", ")")
 sName = Replace(sName, "  ", " ")     'Replace two spaces with one space
 sName = Replace(sName, "   ", " ")    'Replace three spaces with one space
 sName = Replace(sName, "    ", " ")   'Replace four spaces with one space
 sName = Replace(sName, "     ", " ")  'Replace five spaces with one space
 sName = Replace(sName, "      ", " ") 'Replace six spaces with one space

 'Cut out invalid signs.
 sName = Replace(sName, ": ", "_")     'Colan followded by a space
 sName = Replace(sName, ":", "_")      'Colan with no space
 sName = Replace(sName, "/", "_")
 sName = Replace(sName, "\", "_")
 sName = Replace(sName, "*", "_")
 sName = Replace(sName, "?", "_")
 sName = Replace(sName, """", "'")
 sName = Replace(sName, "<", "_")
 sName = Replace(sName, ">", "_")
 sName = Replace(sName, "|", "_")
 sName = Replace(sName, "%", "pc")
 sName = Replace(sName, vbTab, " ")     'Replaces vbTab as this is sometimes a delimiter if copied from excel

End Sub 

Answer 1

需要使用Attachment类的SaveAsFile方法将附件保存到指定路径。例如：

 Sub SaveAttachment()  
   Dim myInspector As Outlook.Inspector  
   Dim myItem As Outlook.MailItem  
   Dim myAttachments As Outlook.Attachments 
   Set myInspector = Application.ActiveInspector  
   If Not TypeName(myInspector) = "Nothing" Then  
     If TypeName(myInspector.CurrentItem) = "MailItem" Then  
       Set myItem = myInspector.CurrentItem  
       Set myAttachments = myItem.Attachments  
       'Prompt the user for confirmation  
       Dim strPrompt As String  
       strPrompt = "Are you sure you want to save the first attachment in the current item to the Documents folder? If a file with the same name already exists in the destination folder, it will be overwritten with this copy of the file."  
       If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then  
         myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") & "\My Documents\" & _  
         myAttachments.Item(1).DisplayName  
       End If  
     Else  
       MsgBox "The item is of the wrong type."  
     End If  
   End If  
 End Sub