Outlook 2010 VBA How to save message including attachment

问题

Hello am using the following code to save messages to a folder, however if a message has an attachment it does not work.

I know if I manually move a message to the hard drive the attachment is still within the *.msg file.

I think it is how I am saving the message in this particular section

oMail.SaveAs sPath & sName, olMSG

How can I alter the following code to do this through 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

Thanks in advance

UPDATE Resolved myself

I have now fixed the issues myself, you need to be careful as it depends on how the email received was created.

If the email and subject particularly was created using excel it will have tab delimiters in it which can throw the above code off. To resolve this use the below code:

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

回答1:

You need to use the SaveAsFile method of the Attachment class to save the attachment to the specified path. For example:

 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

来源：https://stackoverflow.com/questions/28746506/outlook-2010-vba-how-to-save-message-including-attachment

标签

outlook-vba

outlook-2010