VBATools

Jeden z forumowiczów outlook.pl miał pomysł aby diagnozować regułą elementy śmieci i zamiast kasować je, wysyłał do odrębnego folderu. Następnie po przeglądnięciu usunąć z pominięciem kosza w którym też mogą się znajdować ważne informacje (!).

Oczywiście koncepcja nie do końca właściwa (bo po co trzymać wiadomości w koszu).

Napotkanym problemem jest fakt iż skasowanie obiektu z innego folderu niż “elementy usunięte” automatycznie przesuwa go do tego folderu. W tym celu należy wykonać usunięcie z folderu w którym znajdują się śmieci i usunięcie go z kosza z pominięciem pozostawionych tam innych specjalnie pozostawionych nieczystości ;]

Oto procedura która wykona tą czynność:

Sub USUN_z_folderu()
'MVP OShon from VBATools.pl
Dim oApptFolder As MAPIFolder
Dim IoTask As Items, NrObiektu As String
Dim objItem As Object, x As Long
Set oApptFolder = Application.GetNamespace("MAPI") _
 .Folders("Foldery osobiste").Folders("testowy") ' <- tu zmiana nazwy folderu
Set IoTask = oApptFolder.Items
For x = IoTask.Count To 1 Step -1
 DoEvents
 Set objItem = IoTask.item(x)
 NrObiektu = objItem.EntryID
 objItem.Delete
 Call DeleteItem(NrObiektu)
Next
zakoncz:
Set oApptFolder = Nothing
Set IoTask = Nothing
Set objItem = Nothing
Exit Sub
blad:
Resume zakoncz
End Sub

Private Sub DeleteItem(ByVal targetItem$)
Dim item As Object, ns As NameSpace
Set ns = Application.GetNamespace("MAPI")
ns.Logon
on Error Resume Next
Set item = ns.GetItemFromID(targetItem)
If Not item Is Nothing Then item.Delete
End Sub

Jeszcze podpowiedzi:
Osadzenie procedury znajdują sie w tym artykule: Instalacja i uruchamianie makr
Przypisanie procedury do przycisku na pasku skrótów zgodnie z artykułem: Uruchamianie makr przyciskiem na pasku narzędzi

(c) Shon Oskar – www.VBATools.pl