Question

我需要将大量电子邮件复制到文件夹，但不是使用主题行保存它们，而是希望保存的电子邮件的文件名是电子邮件中附件的文件名。

我目前拥有的是使用主题行保存电子邮件的代码：

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

如何确定电子邮件中附件的名称？

Answer 1

DisplayName Property

最佳起点是 - Getting Started with VBA in Outlook 2010

在 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

使用附件名称保存Outlook电子邮件

1 个答案: