Сохраните вложения и создайте подпапки с именами объектов электронной почты

Question

Я создал правило для перемещения писем в подпапки под названием «исходящие» и «входящие комментарии». Мне нужно извлечь вложения в автоматически создаваемые локальные подкаталоги жесткого диска, названные с предметами электронной почты.

Локальный диск F: \ Исходящий

Answer 1

Перебор коллекции Folder.Items и получить объекты MailItem от каждого элемента в коллекции. Затем для каждого MailItem вызовите Attachment.SaveAsFile для каждого объекта в MailItem.Attachments.

Answer 2

Option Explicit 
Const folderPath = "f:\outgoing\" 
Sub GetOutGoingAttachments() 
On Error Resume Next 
Dim ns As NameSpace 
Set ns = GetNamespace("MAPI") 
Dim Inbox As MAPIFolder 
Set Inbox = ns.GetDefaultFolder(olFolderInbox) 

Dim searchFolder As String 
searchFolder = InputBox("Search for Outgoing Reports?") 

Dim Subfolder As MAPIFolder 

Dim Item As Object 
Dim Attach As Attachment 
Dim FileName As String 
Dim i As Integer 



If searchFolder <> "inbox" Then 
Set Subfolder = Inbox.Folders(searchFolder) 
      i = 0 
      If Subfolder.Items.Count = 0 Then 
       MsgBox "There are no messages in the Inbox.", vbInformation, _ 
         "Nothing Found" 
       Exit Sub 
      End If 
        For Each Item In Subfolder.Items 
         For Each Attach In Item.Attachments 
' 
         Attach.SaveAsFile (folderPath & Attach.FileName) 

          i = i + 1 
         Next Attach 
        Next Item 

        '============================================================================== 
         'to search specific type of file: 
'         'For Each Item In Inbox.Items 
'         For Each Atmt In Item.Attachments 
'          If Right(Atmt.FileName, 3) = "xls" Then 
'           FileName = "C:\Email Attachments\" & Atmt.FileName 
'           Atmt.SaveAsFile FileName 
'           i = i + 1 
'          End If 
'         Next Atmt 
'        Next Item 
        '=============================================================================== 

     Else 
     i = 0 
      If Inbox.Items.Count = 0 Then 
       MsgBox "There are no messages in the Inbox.", vbInformation, _ 
         "Nothing Found" 
       Exit Sub 
      End If 
      On Error Resume Next 
      For Each Item In Inbox.Items 
       For Each Attach In Item.Attachments 
        FileName = folderPath & Attach.FileName 
        Attach.SaveAsFile FileName 
        i = i + 1 
       Next Attach 
      Next Item 
    End If 

End Sub