Question

我有一些代码在rfin@example.com收件箱中搜索具有特定主题的邮件，然后调试将主题打印到控制台，我想添加保存这些电子邮件标记的附件的代码搜索。 MSDN文档在这个问题上含糊不清。

我正在寻求帮助的区域用＆＃39; ###从底部注明了12行

Sub Search_Inbox()

'This subroutine searchest the RFin Inbox for the prior month's Acting / Additional forms
'Then it saves the .xlsx attachments

Dim objNamespace As Outlook.NameSpace
Dim olShareName As Outlook.Recipient
Dim myDestFolder As Outlook.Folder
Dim objFolder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim mon As String

mon = Format(Date - 30, "mmmm")

Set objNamespace = Application.GetNamespace("MAPI")
Set olShareName = objNamespace.CreateRecipient("rfin@example.com")   'contains secondary address
Set objFolder = objNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
Set DestFolder = objNamespace.GetSharedDefaultFolder(olShareName, olFolderToDo)

strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & mon & "  Acting / Additional Bonus %'"

Set filteredItems = objFolder.Items.Restrict(strFilter)

If filteredItems.Count = 0 Then
    Debug.Print "No emails found"
    Found = False
Else
    Found = True
    ' this loop displays the list of emails by subject in the debug console and saves the attachments to the specified folder
    dim z as integer
    z=0
    For Each itm In filteredItems
    z=z+1
    Debug.Print itm.Subject
    '### Insert code here to Open the attachments with .xlsx extensions, if any, in each of the emails found, save them as "[Mon] Acting / Additional Bonus (1 to n).xlsx"
    Next
End If
'If the subject isn't found:
If Not Found Then
    'NoResults.Show
Else
   Debug.Print "Found " & filteredItems.Count & " items."
End If
End Sub

Answer 1

尝试以下内容：

for each attach in itm.Attachments
  if (attach.Type = olByValue) or (attach.Type = olEmbeddeditem) Then
    attach.SaveAsFile "c:\temp\" & itm.FileName 
  End If
next

打开并保存附件

1 个答案: