Дмитрий спасибо
Прикладываю макрос вдруг кому пригодиться. Логика была правильная, только нужно развернуть вложенные папки
| Код |
|---|
'---------------------------------------------------------------------------------------
Sub SaveAttachedItemsFromOutlook()
Dim objOutlApp As Object, oNSpace As Object, oIncoming As Object
Dim oIncMails As Object, oMail As Object, oAtch As Object
Dim IsNotAppRun As Boolean
Dim sFolder As String, s As String
Dim fld As Folder
Const nameFolder = "test"
'диалог запроса выбора папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
'отключаем обновление экрана, чтобы наши действия не мелькали
Application.ScreenUpdating = False
'подключаемся к Outlook
On Error Resume Next
Set objOutlApp = GetObject(, "outlook.Application")
If objOutlApp Is Nothing Then
Set objOutlApp = CreateObject("outlook.Application")
IsNotAppRun = True
End If
'получаем доступ к папкам почты
Set oNSpace = objOutlApp.GetNamespace("MAPI")
'подключаемся к папке Входящие, почтового ящика по умолчанию
Set oIncoming = oNSpace.GetDefaultFolder(6).Folders(nameFolder)
'Удаленные ==> GetDefaultFolder(3)
'Исходящие ==> GetDefaultFolder(4)
'Отправленные ==> GetDefaultFolder(5)
'Входящие ==> GetDefaultFolder(6)
'получаем коллекцию писем Входящие(включая подпапки)
Set oIncMails = oIncoming.Items
'просматриваем каждое письмо
For Each oMail In oIncMails
'просматриваем каждое вложение письма
For Each oAtch In oMail.Attachments
'отбираем только файлы Excel
If oAtch Like "*.pdf*" Then
s = GetAtchName(sFolder & oAtch)
oAtch.SaveAsFile s
End If
Next
Next 'Если приложение Outlook было открыта кодом - закрываем
If IsNotAppRun Then
objOutlApp.Quit
End If
'очищаем переменные
Set oIncMails = Nothing
Set oIncoming = Nothing
Set oNSpace = Nothing
Set objOutlApp = Nothing
'возвращаем ранее отключенное обновление экрана
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetShName
' Purpose : Функция получения уникального имени файла
' если файл с именем s уже есть - добавляет номер в скобках
'---------------------------------------------------------------------------------------
Function GetAtchName(ByVal s As String)
Dim s1 As String, s2 As String, sEx As String
Dim lu As Long, lp As Long
s1 = s
lp = InStrRev(s, ".", -1, 1)
If lp Then
sEx = Mid(s, lp)
s1 = Mid(s, 1, lp - 1)
End If
s2 = s
lu = 0
Do While (Dir(s2, 16) <> "")
lu = lu + 1
s2 = s1 & "(" & lu & ")" & sEx
Loop
GetAtchName = s2
End Function |
