P.S Вижу, что в большинстве случаев используют oFolderSrc.Items.Restrict. Т.е работают не c текущими сообщениями в каталоге, а с результатом фильтрации. Может это тоже решает проблему ?
Нет. С результатом фильтрации работать удобнее, т.к. мы можем заранее прикинуть какое кол-во сообщений будем перемещать. Но используя потом For Each для перемещения опять наступаем на те же грабли. Так что последний пример - вранье!
С двумя первыми вариантами можно поиграться, по логике должно работать, но тут (я уже начинаю капризничать) мы узнаем количество перемещенных сообщений только по окончании процесса.
Так что, самый лучший и надежный вариант:
Set oOApp = CreateObject("Outlook.Application")
Set oSrcFolder = oOApp.GetNamespace("MAPI").Folders.Item(folder0)
Set oDestFolder = oOApp.GetNamespace("MAPI").Folders.Item(folder1)
WScript.Echo "В исходной папке: " & oSrcFolder.Items.Count
WScript.Echo "В получателе: " & oDestFolder.Items.Count
strFilter = "[ReceivedTime] < '1/1/2016'"
Set oFilterRecItems = oSrcFolder.Items.Restrict(strFilter)
WScript.Echo "Собираемся переместить: " & oFilterRecItems.Count
j = 0
For i = oFilterRecItems.Count To 1 Step -1
Set Item = oFilterRecItems(i)
If Left(Item.MessageClass, 8) = "IPM.Note" Then
WScript.StdOut.Write Item.ReceivedTime & vbCr
Item.Move oDestFolder
j = j + 1
End If
Next
WScript.Echo " "
WScript.Echo "Реально перемещено: " & j
WScript.Echo "В исходной папке: " & oSrcFolder.Items.Count
WScript.Echo "В получателе: " & oDestFolder.Items.Count
Нашёл ещё несколько примеров реализации:
Тут решается за счёт метода FindNext
https://msdn.microsoft.com/en-us/librar … 60683.aspx
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("Personal Mail")
Set myItem = myItems.Find("[SenderName] = 'Dan Wilson'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
Тут вообще как-то иначе решается: http://superuser.com/a/476193
А тут всё-таки используют For Each. Интересно работает ли это ?
http://www.extendoffice.com/documents/o … -read.html
Sub MoveInbox2Reviewed()
On Error Resume Next
Set oOutlook = CreateObject("Outlook.Application")
Set oNamespace = oOutlook.GetNamespace("MAPI")
Set oFolderSrc = oNamespace.GetDefaultFolder(olFolderInbox)
Set oFolderDst = oFolderSrc.Folders("Reviewed")
Set oFilteredItems = oFolderSrc.Items.Restrict("[UnRead] = False")
For Each oMessage In oFilteredItems
oMessage.Move oFolderDst
Next
End SubP.S Вижу, что в большинстве случаев используют oFolderSrc.Items.Restrict. Т.е работают не c текущими сообщениями в каталоге, а с результатом фильтрации. Может это тоже решает проблему ?
]]>For i = oSrcFolder.Items.Count To 1 Step -1
Set Item = oSrcFolder.Items(i)Если через Shell.Application производить копирование больших файлов, то на экране появляется прогрессбар. При этом "за кулисами" происходит создание временного файла в Temporary директории, и пока идёт процесс копирования, файл в конечном каталоге не появляется. Только по концу процесса происходит перемещение временного файла в конечную директорию с нужным именем. Поэтому иногда такую задачу решают с помощью счётчика. Проще говоря - мы начали копировать и нарастили счётчик i++. В нём уже значение 1. Теперь крутим цикл и проверяем когда items.Count сменится с 0 на 1. И так далее.
Я имею в виду нечто вроде этого:
Option Explicit
Dim oOApp, oSrcFolder, oDestFolder, i
Set oOApp = CreateObject("Outlook.Application")
'...
'Присвоение значений folder0, folder1
'...
Set oSrcFolder = oOApp.GetNamespace("MAPI").Folders.Item(folder0)
Set oDestFolder = oOApp.GetNamespace("MAPI").Folders.Item(folder1)
On Error Resume Next
For Each Item In oSrcFolder.Items
If Left(Item.MessageClass, 8) = "IPM.Note" and Year(Item.CreationTime) < 2016 Then
WScript.Echo Item.CreationTime
Item.Copy.Move oDestFolder
i = i + 1
While oDestFolder.Items.Count < i
WScript.Sleep 100
Wend
End If
Next
P.S Проверить опять же не могу, так как нет у меня аутлука (.
]]>P.S но это лишь предположение. Проверить пока не на чем к сожалению.
]]>If Left(Item.MessageClass, 8) = "IPM.Note" Then
Item.Copy.Move oDestFolder
End IfВопрос решен!
]]>на сервере Exchange
Всё, понял какой сервер. Отбой.
]]>Невозможно открыть пользовательскую форму. Вместо нее будет использована форма Outlook. Объект не поддерживает требуемое действие. [OK]
и, пока его не ткнешь, скрипт висит на строке с копированием.
Что за бред? Какая нах "пользовательская форма"?
И, собственно, главный вопрос: Как предотвратить появление этого долбанного сообщения?
Set oOApp = CreateObject("Outlook.Application")
Set oSrcFolder = oOApp.GetNamespace("MAPI").Folders.Item(folder0)
Set oDestFolder = oOApp.GetNamespace("MAPI").Folders.Item(folder1)
On Error Resume Next
For Each Item In oSrcFolder.Items
If Year(Item.CreationTime) < 2016 Then
WScript.Echo Item.CreationTime
Item.Copy.Move oDestFolder
End If
NextP.S. Хотя код VBS, запостил в треде VBA, т.к. полагаю что тематически это более верно. Да и в VBA можно использовать почти без изменений.
]]>