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

Outlook 2010 VBA如何保存包括附件在内的消息

1 个答案: