Sub ProcessFolder2(CurrentFolder As Outlook.MAPIFolder)
Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempItem As Object

For Each olNewFolder In CurrentFolder.Folders
Set TestItems = olNewFolder.Items 'пробегаем по всем items
For Each itm In TestItems
Set myAttach = itm.Attachments 'пробегаем по всем attachments в каждом item

While myAttach.Count > 0
myAttach.Remove 1 'kill
Wend
Next itm


If olNewFolder.Name <> "Deleted Items" Then
ProcessFolder olNewFolder
End If

Next
End Sub

Так вот этот код, если выполнять по шагам — все отлично ! удаляются все прикрепленные файлы из всех писем, но !!! компилишь — и ничего подобного — удаляются только файлы текущего (активного) письма. Не пойму ! Может быть альтернативный вариант кто- то предложит

Здравствуйте, alekor, Вы писали:

A>Так вот этот код, если выполнять по шагам — все отлично ! удаляются все прикрепленные файлы из всех писем, но !!! компилишь — и ничего подобного — удаляются только файлы текущего (активного) письма. Не пойму ! Может быть альтернативный вариант кто- то предложит

А ты попробуй DoEvents напихать в цикл — авось поможет
Это извесный прикол — если под отладчиком по шагам пашет а атк нет значет где-то очередь сообщений не прососалась

Здравствуйте, dimzon, Вы писали:

D>А ты попробуй DoEvents напихать в цикл — авось поможет
D>Это извесный прикол — если под отладчиком по шагам пашет а атк нет значет где-то очередь сообщений не прососалась

а можно поподробней чуток... вот код:
For Each olNewFolder In CurrentFolder.Folders
Set TestItems = olNewFolder.Items
For Each itm In TestItems
Set myAttach = itm.Attachments

While myAttach.Count > 0
myAttach.Remove 1
openforms = DoEvents
Wend
Next itm

что DoEvents делает ?

Здравствуйте, alekor, Вы писали:

A>Здравствуйте, dimzon, Вы писали:

Попробуй так (гарантий ес-но не даю):

For Each olNewFolder In CurrentFolder.Folders
    Set TestItems = olNewFolder.Items
           For Each itm In TestItems
               Set myAttach = itm.Attachments
        
               While myAttach.Count > 0
                 myAttach.Remove 1
                 openforms = DoEvents
               Wend
        
        DoEvents

    Next itm
Next

A>что DoEvents делает ?
Проталкивает оконные сообщения в очереди

Здравствуйте, alekor, Вы писали:

A>что DoEvents делает ?
DoEvents переносит выполнение этого куска кода в начало Queue треда. Проще говоря исполнение кода в этом месте останавливается и ждет пока не опутеет Queue. А в нем может лежать что угодно, включая ивенты от GUI.

Както странно у тебя рекурсия написанна Ты вообще уверен что хочешь лупать итемы в лупе фолдеров? Возможно в этом и проблема — разнеси это в отдельные лупы, вопервых порядок итераций понизится с O(n^2) до O(n), а там глядишь и проблемы с отпадут.

Попробуй так

Private Sub ClearAttachmentsR(folder As Outlook.MAPIFolder)

Dim fldTmp As Outlook.MAPIFolder
Dim itmTmp As Outlook.MailItem
Dim atchTmp As Outlook.Attachments

    For Each fldTmp In folder.Folders
        ClearAttachmentsR fldTmp
    Next
    
    For Each itmTmp In folder.Items
        Set atchTmp = itmTmp.Attachments
        
        Do While atchTmp.Count
            atchTmp.Remove 1
        Loop
    Next
End Sub

Здравствуйте, BugMan, Вы писали:


BM>Попробуй так
BM>

Sub WalkFolders()
   Dim olApp As Outlook.Application
   Dim olSession As Outlook.NameSpace
   Dim olStartFolder As Outlook.MAPIFolder
   Set olApp = Application
   Set olSession = olApp.GetNamespace("MAPI")
   Set olStartFolder = _
    olSession.GetDefaultFolder(olFolderInbox)
         
    ClearAttachmentsR olStartFolder

End Sub
Private Sub ClearAttachmentsR(folder As Outlook.MAPIFolder)

Dim fldTmp As Outlook.MAPIFolder
Dim itmTmp As Outlook.MailItem
Dim atchTmp As Outlook.Attachments

    For Each fldTmp In folder.Folders
        ClearAttachmentsR fldTmp
    Next
    
    For Each itmTmp In folder.Items
        Set atchTmp = itmTmp.Attachments
        
        Do While atchTmp.Count
            atchTmp.Remove 1
        Loop
    Next
End Sub

BM>

Спасибо за участие.
Проблема в том, что в дебаге он пробегает по всем atchTmp, удаляет их, atchTmp.Count уменьшается. Возвращаешься в окно аутлука — все как и было (atchTmp НЕ удалены) ( Если фокус установлен на каком- то письме, то удаляются вложения текущего письма, но никак не всех. Если фокус не установлен на каком- либо письме, ничего не удаляется.

Усовершенствованная версия:

Private Sub ClearAttachmentsR(folder As Outlook.MAPIFolder)

Dim fldTmp As Outlook.MAPIFolder
Dim itmTmp As Outlook.MailItem
Dim atchTmp As Outlook.Attachments
Dim i As Integer
Dim cnt As Integer

    For Each fldTmp In folder.Folders
        ClearAttachmentsR fldTmp
    Next
    
    For Each itmTmp In folder.Items
    
        Set atchTmp = itmTmp.Attachments
        
        Do While atchTmp.Count
            atchTmp.Item(1).Delete ' ВАЖНО удалять через сам Attachment, а не их collection
        Loop
        itmTmp.Save ' не забываем сохранять
        
    Next
End Sub

Known issues: Не удаляются заблокированые секьюрити патчем атачменты (файлы типа exe, hlp, etc.)

Более зрелый вариант

Private mDelFdrID As String

Private Sub Command1_Click()
    WalkFolders
    MsgBox "done"
End Sub

Private Sub WalkFolders()
Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
   
    Set olApp = CreateObject("Outlook.Application")
    Set olSession = olApp.GetNamespace("MAPI")
    Set olStartFolder = olSession.GetDefaultFolder(olFolderInbox)
         
    mDelFdrID = olSession.GetDefaultFolder(olFolderDeletedItems).EntryID
         
    ClearAttachmentsR olStartFolder

End Sub

Private Sub ClearAttachmentsR(folder As Outlook.MAPIFolder)

Dim fldTmp As Outlook.MAPIFolder
Dim itmTmp As Outlook.MailItem
Dim atchTmp As Outlook.Attachments
    
    ' проверка на вшивость. Проверяй по EntryID а не по имени
    If fldTmp.DefaultItemType <> olMailItem Or fldTmp.EntryID = mDelFdrID Then
        Exit Sub
    End If
    
    For Each fldTmp In folder.Folders
        ClearAttachmentsR fldTmp
    Next
    
    For Each itmTmp In folder.Items
    
        Set atchTmp = itmTmp.Attachments
 
        Do While atchTmp.Count
            atchTmp.Item(1).Delete
        Loop
        itmTmp.Save
        
    Next
End Sub

Bugs :

If fldTmp.DefaultItemType <> olMailItem Or fldTmp.EntryID = mDelFdrID Then

Тут конечно же folder а не fldTmp

И еще маленькая добавка. При удалении выставляй флаг что у данного итема _были_ атачменты, и только в этом случае вызывай Save

Здравствуйте, BugMan, Вы писали:

BM>Bugs :

BM>

BM>If fldTmp.DefaultItemType <> olMailItem Or fldTmp.EntryID = mDelFdrID Then
BM>

BM>Тут конечно же folder а не fldTmp

BM>И еще маленькая добавка. При удалении выставляй флаг что у данного итема _были_ атачменты, и только в этом случае вызывай Save

5 баллов ! EntryID — понятия не имел о нем
спасибо

A>5 баллов ! EntryID — понятия не имел о нем
Баллы выставляются в правом верхнем углу сообщения