Outlook使用主题行保存多个附件，并递增该名称

Question

我花了几个星期和VBA一起玩，我绝对不是这方面的专家。

我正在寻找的是对此代码的修改。

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"

---

你不应该在整个sub btw上使用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)