Save Outlook Emails with Attachment name

问题

I need to copy a whole lot of e-mails to a folder, but instead of saving them using the subject line I want the file name of the saved e-mail to be that of the attachment in the e-mail.

All I currently have is the code to save the e-mail using the subject line:

Sub Sample()
    Dim selectedEmail As MailItem
    Dim emailsub As String

    Set selectedEmail = ActiveExplorer.Selection.Item(1)

    attach = GetValidName(selectedEmail.subject)

    'Debug.Print emailsub

    With selectedEmail
        .SaveAs "C:\direcotry\folder\" & attach & ".msg", OlSaveAsType.olMSG
    End With
End Sub

Function GetValidName(sSub As String) As String
    '~~> File Name cannot have these \ / : * ? " < > |
    Dim sTemp As String

    sTemp = sSub

    sTemp = Replace(sTemp, "\", "")
    sTemp = Replace(sTemp, "/", "")
    sTemp = Replace(sTemp, ":", "")
    sTemp = Replace(sTemp, "*", "")
    sTemp = Replace(sTemp, """", "")
    sTemp = Replace(sTemp, "<", "")
    sTemp = Replace(sTemp, ">", "")
    sTemp = Replace(sTemp, "|", "")

    GetValidName = sTemp
End Function

How can I determine the name of an attachment in the e-mail?

回答1:

DisplayName Property

Best place to start is - Getting Started with VBA in Outlook 2010

Code Tested on Outlook 2010

Option Explicit
Public Sub SaveAsAttchmentName()
    '//  Declare variables-
    Dim olMail As Outlook.MailItem
    Dim olItem As Object
    Dim sPath As String
    Dim sName As String
    Dim olAtt As Outlook.Attachment

    For Each olItem In ActiveExplorer.Selection
        If olItem.MessageClass = "IPM.Note" Then
            Set olMail = olItem
            For Each olAtt In olMail.Attachments
                '// SaveAs Attachment Name-
                sName = olAtt.DisplayName
                '// Call Function-
                ReplaceCharsForFileName sName, "-"
                sName = sName & ".msg"
                '// SaveAs Path-
                sPath = "C:\temp\"
                olMail.SaveAs sPath & sName, olMsg
            Next
        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

来源：https://stackoverflow.com/questions/32898425/save-outlook-emails-with-attachment-name

标签

vba

outlook