Outlook. Автоматическое сохранение вложений
Для автоматического сохранения вложений при приеме новых писем у меня поставлен следующий макрос:
Private Sub Application_NewMail()
For Each myItem In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
DDif = DateDiff("d", myItem.CreationTime, Now)
If DDif < 3 Then
If Right(myItem.SenderEmailAddress, 12) = "блаблабла.ru" Then
Set y = myItem.Attachments
i = 0
Do Until i = y.Count
i = i + 1
If y.Count > 0 Then y(i).SaveAsFile "C:\Attachment\" & y(i).DisplayName
Loop
End If
End If
Next
End Sub
Проблема в том, что макрос эффективно работает только, если в дефолтной папке не больше сотни писем, если там около 1000 писем, то в процессе нахождения нового письма можно сходить чайку попить :)
как можно проверять именно вновь пришедшие письма, а не рыскать по всей папке "Входящие"?
Спасибо.
Private Sub Application_NewMail()
For Each myItem In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
DDif = DateDiff("d", myItem.CreationTime, Now)
If DDif < 3 Then
If Right(myItem.SenderEmailAddress, 12) = "блаблабла.ru" Then
Set y = myItem.Attachments
i = 0
Do Until i = y.Count
i = i + 1
If y.Count > 0 Then y(i).SaveAsFile "C:\Attachment\" & y(i).DisplayName
Loop
End If
End If
Next
End Sub
Проблема в том, что макрос эффективно работает только, если в дефолтной папке не больше сотни писем, если там около 1000 писем, то в процессе нахождения нового письма можно сходить чайку попить :)
как можно проверять именно вновь пришедшие письма, а не рыскать по всей папке "Входящие"?
Спасибо.
Если кому-нибудь интересно решение этой проблемы, то вот макрос, который при получении нового письма, содержащего вложение *.XLS, сохраняет его в отдельную папку.
В макрос можно добавить команду удаления аттачмента, после сохранения - снизив тем самым объем папки оутлука.
Private Sub Application_NewMail()
Dim myolApp As Outlook.Application
Dim myItem As Outlook.MailItem
Set myolApp = CreateObject("Outlook.Application")
Set myNamespace = myolApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
last_count = myFolder.Items.Count
Set myItem = myFolder.Items(last_count)
Set y = myItem.Attachments
i = 0
Do Until i = y.Count
i = i + 1
If y.Count > 0 Then
If Right(y(i).DisplayName, 3) = "xls" Then _
y(i).SaveAsFile "C:\Attachment\" & y(i).DisplayName
End If
Loop
End Sub
В макрос можно добавить команду удаления аттачмента, после сохранения - снизив тем самым объем папки оутлука.
Private Sub Application_NewMail()
Dim myolApp As Outlook.Application
Dim myItem As Outlook.MailItem
Set myolApp = CreateObject("Outlook.Application")
Set myNamespace = myolApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
last_count = myFolder.Items.Count
Set myItem = myFolder.Items(last_count)
Set y = myItem.Attachments
i = 0
Do Until i = y.Count
i = i + 1
If y.Count > 0 Then
If Right(y(i).DisplayName, 3) = "xls" Then _
y(i).SaveAsFile "C:\Attachment\" & y(i).DisplayName
End If
Loop
End Sub