使用主题行在一封电子邮件中保存多个附件，并递增该名称

Question

我想在一封电子邮件中保存多个附件，使用主题行并递增该名称。

Public Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Integer
    Dim lngCount As Integer
    Dim strFile As String
    Dim strFolderpath As String
    Dim strFileName As String
    Dim objSubject As String
    Dim strDeletedFiles As String
    ' Get the path to your My Documents folder
    'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection
    ' The attachment folder needs to exist
    ' You can change this to another folder name of your choice
    ' Set the Attachment folder.
    strFolderpath = "C:\Users\demkep\Documents\"
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
    'Set FileName to Subject
    objSubject = objMsg.Subject
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
    ' Use a count down loop for removing items
    ' from a collection. Otherwise, the loop counter gets
    ' confused and only every other item is removed.
    For i = lngCount To 1 Step -1
    ' Get the file name.
    strFileName = objSubject & ".pdf"
    ' Combine with the path to the Temp folder.
    strFile = strFolderpath & strFileName
    Debug.Print strFile
    ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile
    Next i
    End If
    Next
    ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing 
    Set objOL = Nothing
End Sub

当我收到包含多个附件的电子邮件时，此代码将覆盖最后一个文件。

我想保存（有时最多 30 个 .pdf 文件）为“emailsubject”、“emailsubject(1)”、“emailsubject(2)”、“emailsubject(3)”等。

Answer 1

您没有在循环内更改文件名。类似的东西

strFileName = objSubject & "(" & i & ").pdf"

应该注意这一点。

如果您只需要数字（如果有多个附件），您可以在设置名称之前检查 lngCount 或使用

IIf

If lngCount > 1 Then
    strFileName = objSubject & "(" & i & ").pdf"
Else
    strFileName = objSubject & ".pdf"
End If

或者

strFileName = objSubject & IIf(lngCount>1, "(" & i & ")", "") & ".pdf"

---

顺便说一句，你不应该在整个子系统上使用

On Error Resume Next

。

Answer 2

这里的函数将完全满足您的需要

Function UniqueName(FilePath As String) As String

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FilesystemObject")

    Dim FileName As String
        FileName = FilePath

    Dim Ext As String
        Ext = Chr(46) & FSO.GetExtensionName(FilePath)

    Dim i As Long
        i = 1

    Do While FSO.FileExists(FileName)
        FileName = Left(FilePath, Len(FilePath) - Len(Ext)) & " (" & i & ")" & Ext
        i = i + 1
    Loop

    UniqueName = FileName

End Function

并将其

strFile = strFolderpath & strFileName

更改为

strFile = UniqueName(strFolderpath & strFileName)