Макрос цикла Outlook VBA, перемещающий электронные письма в неуказанных пакетах - PullRequest
Новая
       30

Макрос цикла Outlook VBA, перемещающий электронные письма в неуказанных пакетах

0 голосов
/ 01 марта 2019

Я впервые использую VBA с Outlook.Я получил свой код на работу, но столкнулся со странной проблемой, когда добавил шаг

Задачи:

  1. Сохранить письма отвложенная папка1 в сетевую папку (это работало нормально)
  2. После сохранения Переместить электронные письма из подпапки1 в подпапку2 (добавление этого шага вызвало проблему) (подпапка1 и подпапка2 являются подпапками в Outlook в папке «Входящие» по умолчанию)

Добавление одной строки кода для 2-й задачи вызвало странную проблему: для тех же 12 электронных писем, которые яПри тестировании код запускался без сообщений об ошибках, но одновременно обрабатывал только несколько писем.Мне пришлось бы повторно выполнить код, и для завершения всех 12 писем потребовалось 4 выполнения.

Письма обрабатываются в следующем порядке:

  • 6 писем (то же самое в том же порядкекаждый раз)
  • 3 электронных письма (одно и то же в том же порядке каждый раз)
  • 2 электронных письма (одно и то же в каждом порядке)
  • 1 электронное письмо

В коде нет условий, чтобы остановить его.

Когда я запускаю тот же код без добавления строки для задачи № 2, макрос обрабатывает все 12 электронных писем за один раз.. Закомментирование в этой строке решает "пакетность":
oMail.Move myFolder2

Остальные электронные письма обрабатываются в последующих запусках;только не за один раз.

Вот мой код, заимствованный в основном из: Макрос для сохранения выбранных писем Outlook в папке Windows 

Sub OutlookToDrive()

Dim myNameSpace As Outlook.NameSpace 'Object '(or Outlook.NameSpace)
Dim myFolder1 As Outlook.MAPIFolder  'Object '(or Outlook.MAPIFolder) folder to move FROM
Dim myFolder2 As Outlook.MAPIFolder 'Object '(or Outlook.MAPIFolder) Folder to move TO
Dim oMail As Object 'not specifying as 'mailobject' to include meeting invites
Dim sFileName As String
Dim dtdate As Date
Dim sDestinationFolder As String
Dim sFullPath As String
Dim sFolder1Name As String  'name of folder to move FROM
Dim sFolder2Name As String  'name of folder to move TO
Dim iCount As Integer

sDestinationFolder = "H:\PROD\Supplimentary_Info\"

 'subfolders under the default Inbox folder:
    sFolder1Name = "MoveFrom" 
    sFolder2Name = "MoveTo"    

Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder1 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder1Name)
Set myFolder2 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(sFolder2Name)

'initialize count
iCount = 0

For Each oMail In myFolder1.items

    sFileName = oMail.Subject   'Use email subject as file name

'"ReplaceCharsForFileName" is a function that I'm not including; no issues        
  ReplaceCharsForFileName sFileName, "()"  'replace characters

    dtdate = oMail.ReceivedTime
    sFileName = Format(dtdate, "yyyymmdd", vbUseSystemDayOfWeek, vbUseSystem) & _
            Format(dtdate, "-hhnnss", vbUseSystemDayOfWeek, vbUseSystem) & "-" & sFileName & ".msg"

    sFullPath = sDestinationFolder & "\" & sFileName

    If Dir(sFullPath) = "" Then
        iCount = iCount + 1

        Debug.Print TypeName(oMail) & " " & sFileName
        oMail.SaveAs sFullPath, olMSG   'save to specified path
        DoEvents

        oMail.Move myFolder2 'THIS LINE CAUSING ISSUE; BUT FINE IN BATCHES
        DoEvents
    End If        

Next

    MsgBox "Found " & iCount & " new emails in folder """ & myFolder1 & """ to save to path: " & vbNewLine & vbNewLine & sDestinationFolder

End Sub

При попытке диагностироватьпроблема, сделал список электронных писем в пакетах, они появляются, используя список debug.print.(Номер полужирного префикса - это порядок, в котором они находятся в почтовой папке, текст полужирного префикса - тип электронной почты)

enter image description here

Я изменил общее количество электронных писем длятестирование.Новые партии оставались неизменными, сколько раз я повторял:
Всего 15 электронных писем;партии 8, 4, 2, 1
Всего 6 писем;партии 3, 2, 1
Всего 5 писем;партии 3, 1, 1
Всего 3 электронных письма;партии 2, 1
Всего 2 электронных письма;Оба прошли.ага!

(Группа из 15 счетчиков была создана путем добавления 3 новых писем к оригинальным 12 письмам в папке 1. 12 писем изменили порядок, в котором они были обработаны в новой тестовой группе. Но повторный запуск макроса всегда давалодни и те же электронные письма в тех же новых партиях каждый раз, когда я тестировал)

Ответы [ 2 ]

0 голосов
/ 01 марта 2019

Вот измененный ответ, опубликованный Алексом де Йонгом.
Код работает хорошо, когда цикл изменен на: 

For i = myFolder1.Items.count to 1 step -1
   Set oMail = myFolder1.Items(i)

   'Do your thing

Next i
0 голосов
/ 01 марта 2019

Попробуйте: 

For i = myFolder1.Items.count -1 to 0 step -1
   Set oMail = myFolder1.Items(i)
   'Do your thing

Next i

Я подозреваю, что ваш цикл пропускает элемент, потому что вы удаляете его из папки.

...