在outlook中只保存电子邮件的附件

Question

我在Outlook中自动保存附件有问题，

所以基本上代码是保存选定的附件在电子邮件到特定的文件夹，然而，它不仅保存附件在电子邮件中，但也保存其他类型的图像在电子邮件以及(不在附件中)

我无法找到任何解决方案，使代码只选择附件中的项目进行保存。

下面是完整的代码:

Dim Attachments As Outlook.Attachments
Dim AttachmentsCount As Integer
Dim Email As Outlook.MailItem
Dim FolderObj As Object
Dim FolderPath As String
Dim i As Long
Dim OutlookApp As Outlook.Application
Dim Selection As Outlook.Selection
Dim User As String

FolderPath = "C:XXXDesktopTestAttachment"

Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then 
Else: FolderObj.CreateFolder (FolderPath)
End If

Set OutlookApp = Outlook.Application
Set Selection = OutlookApp.ActiveExplorer.Selection 

AttachmentsCount = 0

For Each Email In Selection
Set Attachments = Email.Attachments
For i = Attachments.Count To 1 Step -1
Attachments.Item(i).SaveAsFile FolderPath & "" & Format(Email.ReceivedTime, "DD.MM.YYYY hhmm") & "_" & Attachments.Item(i).fileName
AttachmentsCount = AttachmentsCount + 1
Next i
Next

If AttachmentsCount > 0 Then
MsgBox "Email Attachment(s) have been saved."
ElseIf AttachmentsCount = 0 Then
MsgBox "No Attachment were found to save."
End If

Answer 1

在HTML格式中，所有图片都被视为附件，并显示在邮件正文中。我试过你的代码，可以用，但是附件。Count不止显示为附件。在我的例子中- 1 .xlsx文件显示为附件，正文中显示4个小图像。

您可以检查附件是否嵌入了功能

Sub saveatt()
Dim Attachments As Outlook.Attachments
Dim AttachmentsCount As Integer
Dim Email As Outlook.MailItem
Dim FolderObj As Object
Dim FolderPath As String
Dim i As Long
Dim OutlookApp As Outlook.Application
Dim Selection As Outlook.Selection
Dim User As String

FolderPath = "C:UsersxxxDownloads"

Set FolderObj = CreateObject("Scripting.FileSystemObject")
If FolderObj.FolderExists(FolderPath) Then
Else: FolderObj.CreateFolder (FolderPath)
End If

Set OutlookApp = Outlook.Application
Set Selection = OutlookApp.ActiveExplorer.Selection

AttachmentsCount = 0

For Each Email In Selection
Set Attachments = Email.Attachments
For i = Attachments.Count To 1 Step -1
If IsEmbeddedAttachment(Attachments.Item(i)) = False Then
Attachments.Item(i).SaveAsFile FolderPath & "" & Format(Email.ReceivedTime, "DD.MM.YYYY hhmm") & "_" & Attachments.Item(i).FileName
AttachmentsCount = AttachmentsCount + 1
End If
Next i
Next

If AttachmentsCount > 0 Then
MsgBox "Email Attachment(s) have been saved."
ElseIf AttachmentsCount = 0 Then
MsgBox "No Attachment were found to save."
End If
End Sub
Function IsEmbeddedAttachment(Attach As Attachment)
Dim xItem As MailItem
Dim xCid As String
Dim xID As String
Dim xHtml As String
On Error Resume Next
IsEmbeddedAttachment = False
Set xItem = Attach.Parent
If xItem.BodyFormat <> olFormatHTML Then Exit Function
xCid = ""
xCid = Attach.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F")
If xCid <> "" Then
xHtml = xItem.HTMLBody
xID = "cid:" & xCid
If InStr(xHtml, xID) > 0 Then
IsEmbeddedAttachment = True
End If
End If
End Function