保存带有主题名称的附件

Question

我试图将所有电子邮件的附件保存到某个文件夹中。这是一个日常的过程，所以它也会删除下载的附件。

文件的名称不是恒定的，我需要它们在保存为它们来自电子邮件的主题名称后具有相同的名称。

每封电子邮件包含一个附件。是否有可能修改当前的代码，使其保存与主题名称而不是附件名称?

Sub Spremanje()
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Mapa za spremanje izvještaja", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note:  BrowseForFolder doesn't add a trailing slash
' Ask the user to select an Outlook folder to process
Dim olPurgeFolder As Outlook.MAPIFolder
Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
If olPurgeFolder Is Nothing Then Exit Sub
' Iteration variables
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment

Dim sSavePathFS As String
Dim sDelAtts
For Each msg In olPurgeFolder.Items
sDelAtts = ""
' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
' on our olPurgeFolder.Items collection.  The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment.  Each update will
' reindex the collection.  As a result, it does not provide a reliable means for iteration.
' This is why the For Each loops will not work.
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method
' which will decrement msg.Attachments.Count by one each time.
While msg.Attachments.Count > 0
' Save the file
sSavePathFS = fsSaveFolder.Self.Path & "" & msg.Subject(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment.  We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us.  Use some well placed Debug.Print statements to see
' the behavior.
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted:  " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To:  " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg.  If you forget this line, the attachments will not be deleted.
msg.Save
End If
Next
End Sub    

Answer 1

代码中路径设置如下:

' Save the file
sSavePathFS = fsSaveFolder.Self.Path & "" & msg.Subject(1).FileName

要使用主题，可以在代码中使用subject属性:

sSavePathFS = fsSaveFolder.Self.Path & "" & msg.Subject & " - " & msg.Attachments(1).FileName

但是您需要为附加文件创建一个唯一的文件名，因此为附加文件引入某种ID是有意义的。它可以是收到项目的日期字符串(ReceivedTime)，也可以是与特定附件唯一相关的任何其他标识符。

---

我还建议替换代码中的while循环，这样您就可以在代码中找到当前迭代的邮件项目，而无需维护其他索引:

' This While loop is controlled via the .Delete method
' which will decrement msg.Attachments.Count by one each time.
While msg.Attachments.Count > 0

可以在代码中使用反向for循环。

For i = msg.Attachments.Count To 1 Step -1

所以，你可以很容易地得到这个项目:

Set att = msg.Attachments.Item(i)