Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Выгрузка писем Outlook по дате
 
Цитата
The_Prist написал:
Вот здесь я приводил код и программку, которые сохраняют вложения. Там можно чуть подправить под Вашу задачу и все. Или подсмотреть принцип выбора папок: Сохранить вложения из Outlook в указанную папку
Здравствуйте! подскажите пожалуйста в чем может быть ошибка.
немного подправил под себя ваш макрос, но почему-то когда у меня на одну дату приходит 3 письма он сохраняет только первое из них.
вот моя модификация кода:

Код
'СОХРАНЕНИЕ ВЛОЖЕНИЙ С РАСКЛАДКОЙ ПО ПАПКАМ
Sub Sohr_RogaiKopita()

Dim SchetAccauntov As Long 'инициализация переменной счетчика
Dim SchetPapok1Urov As Long 'инициализация переменной счетчика
Dim SchetPapok2Urov As Long 'инициализация переменной счетчика
Dim saveFolder As String
Dim Uchastok As String
Dim Zakazchik As String
'1.1 инициализация переменных писем вложений
Dim Vlogenie As Object 'Outlook.Attachment
Dim SpisokPisem As Object
Dim OtdPismo As Object
'1.2 инициализация переменных папок
Dim OlAPP As Object 'инициализация приложения Outlook
Dim PapkiAccauntov As Object 'инициализация переменной папок аккаунтов
Dim Ur1Papki As Object 'инициализация переменной папок 1 уровня
Dim Ur2Papki As Object 'инициализация переменной папок 2 уровня
Dim Ur3Papki As Object 'инициализация переменной папок 3 уровня

Application.ScreenUpdating = False 'отключаем обновление экрана, чтобы наши действия не мелькали
On Error Resume Next
Set OlAPP = GetObject(, "outlook.Application") 'подключаемся к Outlook
    If OlAPP Is Nothing Then
        Set OlAPP = CreateObject("outlook.Application")
        IsNotAppRun = True
    End If
Set PapkiAccauntov = OlAPP.GetNamespace("MAPI") 'присвоение переменной всех папок
saveFolder = "C:\Test\"

SchetAccauntov = PapkiAccauntov.Folders.Count 'Подсчёт аккаунтов
For i = 1 To SchetAccauntov 'Ограничиваем индексом перебор перебор аккаунтов
  Set Ur1Papki = PapkiAccauntov.Folders(i)
    If i = 1 Then 'мне нужен второй аккаунт
    SchetPapok1Urov = Ur1Papki.Folders.Count 'Подсчёт папок 1 уровня у меня это Участок
            For j = 1 To SchetPapok1Urov
                    If j = 13 Then 'j > 8 And j < 16 Then 'Ограничиваем индексом перебор папок 1 уровня у меня это Участок
                        Set Ur2Papki = Ur1Papki.Folders(j) 'Считывание имен папок 2 уровня
                        Uchastok = Ur2Papki.Name
                        saveFolderUchastok = saveFolder & Uchastok
                            If Dir(saveFolderUchastok, vbDirectory) = "" Then 'Проверка наличия папки Участка в папке "Test"
                              MkDir saveFolderUchastok
                            End If
                        SchetPapok2Urov = Ur2Papki.Folders.Count 'Подсчёт папок 2 уровня
                             For k = 1 To SchetPapok2Urov 'Ограничиваем индексом перебор папок 2 уровня у меня это Заказчик
                                 Set Ur3Papki = Ur2Papki.Folders(k) 'Считывание имен папок 3 уровня
                                 Zakazchik = Ur3Papki.Name
                                 If Zakazchik Like "Рога и Копыта" Then
                                 Debug.Print Zakazchik
                                 saveFolderZakazchik = saveFolderUchastok & "\" & Zakazchik
                                    If Dir(saveFolderZakazchik, vbDirectory) = "" Then 'Проверка наличия папки Заказчика в папке Участка
                                      MkDir saveFolderZakazchik
                                    End If
                                    Set SpisokPisem = Ur3Papki.Items 'Присваем переменной список писем из нужной папки
                                    Debug.Print Ur3Papki.Items.Count
                                    For Each OtdPismo In SpisokPisem 'Перебираем письма в списке
                                        For Each Vlogenie In OtdPismo.Attachments 'Перебираем вложения в перебираемых письмах
                                            If OtdPismo.ReceivedTime > (Date - 31) Then
                                            Debug.Print Vlogenie
                                            Debug.Print Format(OtdPismo.ReceivedTime, " YYYY.MM.DD  hh-mm-ss")
                                                If Vlogenie Like "*.x*" Then '  "*.xl*"
                                                Debug.Print Ur3Papki.Items.Index
                                                    Vlogenie.SaveAsFile saveFolderZakazchik & "\" & Format(OtdPismo.ReceivedTime, "YYYY.MM.DD  hh-mm-ss") & "_" & Vlogenie.Filename
                                                End If
                                            End If
                                        Next
                                    Next
                                    End If
                            Next
                    End If
            Next
    End If
Next
    If IsNotAppRun Then 'Если приложение Outlook было открыта кодом - закрываем
        objOutlApp.Quit
    End If
'очищаем переменные
Set OtdPismo = Nothing
Set SpisokPisem = Nothing
Set PapkiAccauntov = Nothing
Set OlAPP = Nothing
'возвращаем ранее отключенное обновление экрана
Application.ScreenUpdating = True
End Sub


Изображения
Скрытый текст
Изменено: Renat77 - 08.05.2019 19:33:45
Вопрос по созданию XML-файла по XSD-схеме из таблицы XLS.
 
Подтверждаю актуальность задачи. нужен макрос либо надстройка. позволяющая любой домохозяйке файл xlsx/xls выгружать xml !

"СИСТЕМНАЯ ИНФОРМАЦИЯ МАССОВОЙ ЗАГРУЗКИ
XSD-схема для массовой загрузки оферт находится по ссылке
Используется тип offerImportPacket
Справочники Портала поставщиков можно скачать, перейдя по следующим ссылкам:
Справочник видов продукции (categoryType)
Справочник валют (currencyType)
Справочник характеристик (detailType)
Справочник характеристик по видам продукции (category)
Справочник значений НДС (ndsType)
Справочник единиц упаковки (packageType)
Справочник тегов (tagType)
Справочник единиц измерения (okeiType)
Справочник КПГЗ (kpgzType)"

Схема xsd
Скрытый текст
Изменено: Renat77 - 17.04.2018 16:44:23
Регулярные выражения, Подкрашивание найденных значений с помощью регулярных выражений
 
Добрый день!

По работе мне часто приходится выделять однотипный текст. Бороздя просторы интернета, нашел здесь прием, но хотелось бы прикрутить к нему регулярные выражения. Попытался скрестить, но код некорректно работает( не все выделяет).Подскажите что не так в файле примере и как можно оптимизировать код
Скрытый текст
Изменено: Renat77 - 29.09.2016 18:42:37 (добавил код)
Страницы: 1
Наверх