Я не удивлен, что банк не хочет получать доступ к своим электронным письмам. Вы можете изменить отправителя, добавить или удалить получателей или изменить текст. Трудно сделать что-либо из этого, не оставляя следа, но это возможно. Вы не хотите ничего менять;вы просто хотите автоматизировать сохранение вложения, чтобы это могли сделать ваши специалисты и Outlook.
Прежде чем пытаться выполнить более сложные части вашего требования, позвольте нам проверить, возможно ли ваше требование. Я не знаю, сколько вы знаете о Excel VBA. Если я попрошу вас сделать что-то, чего вы не понимаете, вернитесь с вопросами.
Создайте книгу с поддержкой макросов в удобном месте. Имя рабочей книги не имеет значения.
Откройте рабочую книгу, а затем редактор VBA.
Нажмите [Инструменты], а затем [Ссылки]. Вы получите выпадающее меню всех доступных библиотек. Прокрутите вниз, пока не найдете «Библиотека объектов Microsoft Outlook nn.0». «Nn» обозначает используемую версию Outlook, которая, как я понимаю, будет для вас «14». Нажмите на поле слева, и появится галочка. Нажмите [OK]. Это даст вам доступ к Outlook из Excel.
В Project Explorer вы увидите что-то вроде:
- VBAProject (YourNameForWorkbook.xlsm)
- Microsoft Excel Objects
Sheet1 (Sheet1)
ThisWorkbook
Если один из минусов является плюсом, нажмите на этот плюс.
Нажмите [ThisWorkbook]. Пустая область кода появится справа от окна редактора VBA. Скопируйте приведенный ниже код в эту область.
Внутри кода вы найдете строки, начинающиеся с '###. Эти строки сообщают вам об изменениях, которые вы должны внести, или о том, что вы должны проверить. Внесите необходимые изменения, а затем сохраните и закройте рабочую книгу. Откройте книгу. При удаче макрос будет запускаться автоматически, а рабочий лист по умолчанию сообщит о том, что он сделал. Вероятно, он обнаружил неправильный адрес электронной почты и сохранил неправильное вложение. Это не имеет значения. Если вы можете сохранить любое вложение, вы можете сохранить вложение, которое вы хотите.
Option Explicit
Sub Workbook_Open()
'### Replace "C:\DataArea\SO\" with the name of a disc folder on your system
' Make sure your folder name ends with \.
Const DiscFldrDest As String = "C:\DataArea\SO\"
'### The name of the default worksheet depend on the local language. Replace
' "Sheet1" is this is not the default name for you.
Const WshtOutName As String = "Sheet1"
' ### The subject of the email. Correct if I have misunderstood your comment ' ###
Const Subject As String = "ISIN List: Financial Sanctions - ISIN screening" ' ###
Dim AppOut As Outlook.Application
Dim Found As Boolean
Dim InxA As Long
Dim InxI As Long
Dim OutFldrInbox As Outlook.Folder
Dim RowNext As Long
Dim WshtOut As Worksheet
Set AppOut = CreateObject("Outlook.Application")
With AppOut
With .Session
Set OutFldrInbox = .GetDefaultFolder(olFolderInbox)
End With
End With
Set WshtOut = Worksheets(WshtOutName)
RowNext = WshtOut.Cells(Rows.Count, "A").End(xlUp).Row + 1
'### Change if you prefer different date or time formats
WshtOut.Cells(RowNext, "A").Value = "Macro activated at " & _
Format(Now(), "h:mm") & " on " & _
Format(Now(), "d mmm yy")
RowNext = RowNext + 1
'### GetDefaultFolder is not much use on my system because I have two
' email addresses, each with their own Inbox, neither of which is
' the default Inbox. Probably you only have one work email address
' which is the default for you. To check, the following statement
' outputs the name of the default Inbox's mailbox. Tell me if it is
' not the mail box you want.
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Inbox accessed"
WshtOut.Cells(RowNext, "B").Value = OutFldrInbox.Parent.Name
RowNext = RowNext + 1
Found = False
With OutFldrInbox
For InxI = .Items.Count To 1 Step -1
With .Items(InxI)
If .Subject = Subject And .Attachments.Count > 0 Then '###
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved from email" '###
WshtOut.Cells(RowNext, "B").Value = "With subject"
WshtOut.Cells(RowNext, "C").Value = .Subject
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "B").Value = "Received"
'WshtOut.Cells(RowNext, "C").Value = .ReceivedTime
WshtOut.Cells(RowNext, "C").Value = Format(.ReceivedTime, "\a\t h:mm \o\n d mmm yy")
'WshtOut.Cells(RowNext, "C").NumberFormat = "at h:mm on d mmm yy"
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved" '###
For InxA = 1 To .Attachments.Count '###
If UCase(Right$(.Attachments(InxA), 4)) = ".ZIP" Then '###
WshtOut.Cells(RowNext, "B").Value = .Attachments(InxA).Filename '###
.Attachments(1).SaveAsFile DiscFldrDest & .Attachments(1).Filename '###
Found = True '###
Exit For '###
End If '###
Next '###
End If
End With
Next
With WshtOut
If Not Found Then
.Cells(RowNext, "B").Value = "No email with correct subject and a ZIP attachment found"
RowNext = RowNext + 1
End If
.Columns.AutoFit
.Cells(RowNext, "A").Select
End With
End With
End Sub