Outlook блокирует файлы с неизвестными расширениями . Можно ли зарегистрировать свои расширения? Это нужно для того чтобы принимать вложения и сохранять в определенной папке. Или есть другие варианты по приему и сохранению?
Private Sub Кнопка1_Click()
MySubject = "тема" 'Установка заданной темы
MyFilePath = "C:\1.txt" 'Установка названия файла
MyFilePath1 = "C:\2.txt" 'Установка названия файла
Call GetMessage(MySubject, MyFilePath, MyFilePath1)
End Sub
Function GetMessage(ByVal FindSubject As String, ByVal MyFilePath As String, ByVal MyFilePath1 As String)
Dim MySubject As String
Dim myOlApp As Object
Dim myNameSpace As Object
Dim MyFolder As Object
Dim myItem As Object
Dim myAttachments As Object
Dim i As Long, x As Long
Dim OlNotRunning As Boolean


On Error Resume Next
Set myOlApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
OlNotRunning = True
Err.Clear
Set myOlApp = CreateObject("Outlook.Application")
End If
'=====================================================
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set MyFolder = myNameSpace.GetDefaultFolder(6)
x = MyFolder.Items.Count
With MyFolder
For i = 1 To x
Set myItem = .Items(i)
MySubject = myItem.Subject

If MySubject = FindSubject Then
Set myAttachments = myItem.Attachments
'Сохранение с заданным именем файла вложения
myAttachments.Item(1).SaveAsFile MyFilePath
myAttachments.Item(2).SaveAsFile MyFilePath1
'...или c исходным именем вложения:
'myAttachments.Item(1).SaveAsFile myAttachments.Item(1).DisplayName
'myAttachments.Item(2).SaveAsFile myAttachments.Item(2).DisplayName
'myItem.Delete
Exit For
End If
Next i
End With

If OlNotRunning = True Then
myOlApp.Quit
End If
End Function