Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?
26.11.2020, 07:06:47

Войти
Добавляйтесь в нашу группу ВКонтакте - будьте в курсе всех новых событий сайта, узнавайте первым обо всех акциях и новых статьях!
31 629 Сообщений в 5 073 Тем от 10 747 Пользователей
Последний пользователь: proofpuppy8
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Outlook и VBA
| | |-+  Как обратиться к вложениям в письмах на втором аккаунте аутлук через макрос Exce
Страниц: [1]   Вниз
Печать
Автор Тема: Как обратиться к вложениям в письмах на втором аккаунте аутлук через макрос Exce  (Прочитано 346 раз)
0 Пользователей и 1 Гость смотрят эту тему.
johnyb
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 2


Просмотр профиля
« : 26.10.2020, 10:59:40 »

Здравствуйте, многоуважаемые гуру!
Не могу решить проблему с обработкой и архивацией писем с доп. аккаунта в аутлуке, через макрос эксель.
Есть такой код:
Код
Код: (vb)
Sub mail_attachments_download()
Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
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, st As String, bodym As String
Application.ScreenUpdating = False
actbk = ThisWorkbook.Name
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)
Set oIncMails = oIncoming.Items
 
 
    For Each oMail In oIncMails.Restrict("[Unread]=TRUE")
        For Each oAtch In oMail.Attachments
            For i = 2 To Workbooks(actbk).Worksheets("Suppliers list page").UsedRange.Rows.Count
                If InStr(1, oAtch, Workbooks(actbk).Worksheets("Suppliers list page").UsedRange.Cells(i, 1).Value, vbTextCompare) <> 0 Then
                    If Right(oAtch, 4) = ".xls" Then
                        mnslft = 4
                    Else
                        mnslft = 5
                    End If
                    sFolder = Workbooks(actbk).Worksheets(2).UsedRange.Cells(i, 2).Value
                    If Right(sFolder, 1) <> "\" Then
                        sFolder = sFolder & "\"
                    End If
                    oAtch1 = Left(oAtch, Len(oAtch) - mnslft) & " (Downloaded " & Left(Now, 10) & ")" & Right(oAtch, mnslft)
                    oAtch3 = Left(oAtch, Len(oAtch) - mnslft) & " (Downloaded " & Left(Now, 13) & "h" & Left(Right(Now, 5), 2) & "m" & Right(Now, 2) & "s)"
                    st = sFolder & oAtch1
                    oAtch.SaveAsFile st
                    n = Workbooks(actbk).Worksheets("Archive page").UsedRange.Rows.Count + 1
                    Workbooks(actbk).Worksheets("Archive page").UsedRange.Cells(n, 1).Value = Workbooks(actbk).Worksheets("Suppliers list page").UsedRange.Cells(i, 1).Value
                    Workbooks(actbk).Worksheets("Archive page").UsedRange.Cells(n, 2).Value = oMail.Sender.GetExchangeUser.PrimarySmtpAddress
                    Workbooks(actbk).Worksheets("Archive page").UsedRange.Cells(n, 3).Value = oAtch
                    Workbooks(actbk).Worksheets("Archive page").UsedRange.Cells(n, 4).FormulaR1C1 = "=HYPERLINK(""" & sFolder & """,""" & sFolder & """)"
                    Workbooks(actbk).Worksheets("Archive page").UsedRange.Cells(n, 5).Value = Now
                    oMail.Unread = False
                    oMail.SaveAs (sFolder & "Mail archive\" & oAtch3 & ".msg")
                End If
            Next
        Next
    Next
End Sub

Он прекрасно работает, сохраняет вложения, и заносит в лист архива данные.
Но игнорирует второй аккаунт в аутлуке, а мне необходимо, чтобы макрос выбирал сообщения именно из него.
Аккаунт шаренный.
Я попытался заменить Set oIncoming = oNSpace.GetDefaultFolder(6) на Set oIncoming = oNSpace.GetSharedDefaultFolder("мыло_аккаунта",6), но при этом скрипт просто не определяет папку.
Подскажите, пожалуйста, в чем ошибка?
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +453/-0
Офлайн Офлайн

Сообщений: 5 351



Просмотр профиля WWW
« Ответ #1 : 26.10.2020, 11:15:07 »

Можете скачать файл по ссылке: Сохранить вложения из Outlook в указанную папку
Там есть пример определения разных ящиков.
Т.е. по сути Вам надо вместо
Код: (vb)
Set oIncoming = oNSpace.GetDefaultFolder(6)

указать конкретную папку:
Код: (vb)
oNSpace.Folders("yourmail").Name
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
johnyb
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 2


Просмотр профиля
« Ответ #2 : 27.10.2020, 07:28:07 »

Что-то я не понял, как я это должен применить?

Код: (vb)
oNSpace.Folders("yourmail").Name 


Заменить прямо в скрипте? или там функция в примере есть? я что-то не нашел, извините за тупняк
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +453/-0
Офлайн Офлайн

Сообщений: 5 351



Просмотр профиля WWW
« Ответ #3 : 27.10.2020, 08:25:00 »

как я это должен применить?
м-да...просто я подумал хоть какие-то навыки есть, судя по сообщению Улыбка
Так же, как пытались применить здесь:
попытался заменить Set oIncoming = oNSpace.GetDefaultFolder(6) на Set oIncoming = oNSpace.GetSharedDefaultFolder("мыло_аккаунта",6)
Просто Вы неверно обращались - к GetSharedDefaultFolder, а надо просто к папке:
Код: (vb)
Set oIncoming = oNSpace.Folders("yourmail")

Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru