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)