Как автоматически сохранить вложение от определенного отправителя - PullRequest
Новая
       9

Как автоматически сохранить вложение от определенного отправителя

0 голосов
/ 29 января 2019

Мне нравится создавать макрос Outlook, который автоматически сохраняет вложение от определенного отправителя в заранее определенной папке.

В настоящее время я использую этот код, но он не работает: 

Public WithEvents objInboxItems As Outlook.Items

Private Sub Application_Startup()
   Set objInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
   Dim objMail As Outlook.MailItem
   Dim strSenderAddress As String
   Dim strSenderDomain As String
   Dim objAttachment As Attachment
   Dim strFolderPath As String
   Dim strFileName As String

   If Item.Class = olMail Then
      Set objMail = Item

      'Get sender domain
      strSenderAddress = objMail.SenderEmailAddress
      'strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "@"))

      'Change to the specific domain as per your needs
      If strSenderAddress = "Da.Te@union.de" Then
         If objMail.Attachments.Count > 0 Then
            For Each objAttachment In objMail.Attachments
                'Change the folder path where you want to save attachments
                strFolderPath = "U:\Test"
                strFileName = objMail.Subject & " " & Chr(45) & " " & objAttachment.FileName
                objAttachment.SaveAsFile strFolderPath & strFileName
            Next
         End If
      End If
   End If
End Sub

Любая помощь, которую вы можете предоставить, высоко ценится!

Этот код изначально был здесь , с небольшими изменениями.

1 Ответ

0 голосов
/ 30 января 2019

Как насчет следующего ... Не забудьте перезапустить Outlook 

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    Dim Filter As String
        Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & _
                           Chr(34) & " Like '%Da.Te@union.de%' And " & _
                           Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                           Chr(34) & "=1"

    Set Items = Inbox.Items.Restrict(Filter)
End Sub



Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then

        Dim FilePath As String
            FilePath = "C:\Temp\"

        Dim AtmtName As String
        Dim Atmt As attachment

        For Each Atmt In Item.Attachments
            AtmtName = FilePath & Atmt.filename
            Atmt.SaveAsFile AtmtName
        Next
    End If
End Sub

Items.ItemAdd Event (Outlook) Происходит, когда один или несколько элементов добавляются в указанную коллекцию. Это событие не запускается при одновременном добавлении большого количества элементов в папку .Это событие недоступно в Microsoft Visual Basic Scripting Edition (VBScript).

Элементы.Метод Restrict является альтернативой использованию метода Find или метода FindNext для перебора определенных элементов в коллекции.Методы Find или FindNext работают быстрее, чем фильтрация, если имеется небольшое количество элементов.Метод Restrict значительно быстрее, если в коллекции имеется большое количество элементов, особенно если ожидается, что в большой коллекции будет найдено только несколько элементов.

Фильтрация элементов с использованием сравнения строк , поддерживаемых фильтрами DASL, включает эквивалентность, префикс, фразу и сопоставление подстроки.Обратите внимание, что при фильтрации по свойству Subject префиксы, такие как «RE:» и «FW:», игнорируются.

...