VBA Tools

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 ze śmieciami
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 oFolder As MAPIFolder, item As Object
Set oFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems)
 For Each item In oFolder.Items
 DoEvents
 If item.EntryID = targetItem Then
  item.Delete
  Exit For
 End If
 Next item
Set oFolder = Nothing
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

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.