Głównymi parametrami, jakie klasyfikują obiekty typu email są:

Zestawienie tych wartości i porównanie ich z ze sobą wyłoni obiekty, które będą nadawały się do usunięcia. Aby przyspieszyć proces porównania, przydatne będzie ustawienie tych wartości w porządku alfabetycznym (np. rozpoczynając od daty).

Aby przystąpić do działania należy wpierw zaznajomić się z edytorem VBA, wbudowanym w Microsoft Outlook. Uruchamiamy go poprzez skrót klawiszowy Alt+F11. Więcej na ten temat można przeczytać w tym artykule.

 

Osadzamy formę wraz z kodem (do pobrania gotowa forma) przesuwając plik myszą o rozszerzeniu .frm na miejsce drzewa projektu. Interfejs/forma składa się z dwóch plików: Plik o rozszerzeniu .frx, w którym osadzone są kontrolki użyte w projekcie oraz ich położenie. Drugi plik posiada rozszerzenie .frm, w którym zapisany jest kod VBA.

 

Następnie tworzymy Moduł Menu/Insert/Module, w którym wpisujemy kod wywołania formy:

 

 

Rys.1. Ekran programu zestawiający wiadomości do porównania.

 

Option Explicit
Dim oFolder As MAPIFolder
Dim item As Object, i&
Dim KillItem As MailItem

Private Sub Anuluj_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim clmX As ColumnHeader
With Lista
    Set clmX = .ColumnHeaders.Add(, , "Utworzono", .Width / 6.02)
    Set clmX = .ColumnHeaders.Add(, , "Nadawca", .Width / 4)
    Set clmX = .ColumnHeaders.Add(, , "Rozmiar [kb]", .Width / 10)
    Set clmX = .ColumnHeaders.Add(, , "Temat", .Width / 2)
    Set clmX = .ColumnHeaders.Add(, , "EntryID", .Width / 2)
    Set clmX = Nothing
End With
With Application.ActiveExplorer.CurrentFolder
    Ilosc.Caption = "Ilość 0\" & .Items.Count
    Me.Caption = Me.Caption & " " & Chr(34) & .Name & Chr(34)
    Me.Height = 309
End With
End Sub

Private Sub Czytaj_Click()
Dim item As Object, itmX As ListItem, dodany&

Delete_d.Enabled = False
Anuluj.Enabled = False
Wielkosc.Enabled = False
Lista.ListItems.Clear
dodany = 0

Set oFolder = Application.ActiveExplorer.CurrentFolder
For Each item In oFolder.Items
DoEvents
    On Error Resume Next
    Set itmX = Lista.ListItems.Add(, , item.CreationTime)
        itmX.SubItems(1) = item.SenderEmailAddress
        itmX.SubItems(2) = Format(item.Size, "# ###")
        itmX.SubItems(3) = item.Subject
        itmX.SubItems(4) = item.EntryID
        dodany = dodany + 1
    On Error GoTo 0
Ilosc.Caption = "Ilość " & dodany & "\" & oFolder.Items.Count
Next item
Set itmX = Nothing
Delete_d.Enabled = True
Anuluj.Enabled = True
Wielkosc.Enabled = True
End Sub

Private Sub Delete_d_Click()
Set oFolder = Application.ActiveExplorer.CurrentFolder
If oFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems) Then
Dim Pytanie
Pytanie = MsgBox("Znajdujesz się w folderze " & Chr(34) & _
        Application.ActiveExplorer.CurrentFolder.Name & Chr(34) & vbCr & _
       "Uruchomienie procedury permanentnie usunie elementy z tego folderu." & vbCr & _
       "Czy kontynuować?", vbQuestion + vbDefaultButton2 + vbYesNo, "VBATools.pl")
If Pytanie = vbNo Then Exit Sub
End If

If Lista.ListItems.Count < 1 Then MsgBox "Brak elementów do porównania", _
    vbInformation, "VBATools.pl": Exit Sub

With Progress
    .Top = 264
    .value = 0
    .max = Lista.ListItems.Count
    .Visible = True
End With

Delete_d.Visible = False
Czytaj.Visible = False
Anuluj.Visible = False
Ilosc.Visible = False
Wielkosc.Visible = False
Lista.Sorted = True
Dim ile&: ile = 0

For i = 1 To Lista.ListItems.Count - 1
DoEvents
Progress.value = i
If Wielkosc.value = True Then
    If Lista.ListItems(i) & Lista.ListItems(i).ListSubItems(1) & _
                            Lista.ListItems(i).ListSubItems(3) = _
       Lista.ListItems(i + 1) & Lista.ListItems(i + 1).ListSubItems(1) & _
                                Lista.ListItems(i + 1).ListSubItems(3) Then
       Call DeleteItem(Lista.ListItems(i).ListSubItems(4))
       ile = ile + 1
    End If
Else
    If Lista.ListItems(i) & Lista.ListItems(i).ListSubItems(1) & _
                            Lista.ListItems(i).ListSubItems(2) & _
                            Lista.ListItems(i).ListSubItems(3) = _
       Lista.ListItems(i + 1) & Lista.ListItems(i + 1).ListSubItems(1) & _
                                Lista.ListItems(i + 1).ListSubItems(2) & _
                                Lista.ListItems(i + 1).ListSubItems(3) Then
       Call DeleteItem(Lista.ListItems(i).ListSubItems(4))
       ile = ile + 1
    End If
End If
Next i

If ile > 0 Then
    MsgBox "Umieszczono w folderze " & Chr(34) & _
    Application.GetNamespace("MAPI").GetDefaultFolder(olFolderDeletedItems).Name & Chr(34) & _
    " " & ile & " wiadomości", vbExclamation, "VBATools.pl"
Else
    MsgBox "Nie znaleziono żadnych duplikatów w folderze " & oFolder.Name, _
        vbInformation, "VBATools.pl"
End If

Progress.Visible = False
Delete_d.Visible = True
Czytaj.Visible = True
Anuluj.Visible = True
Ilosc.Visible = True
Wielkosc.Visible = True
End Sub

Private Sub DeleteItem(ByVal targetItem$)
Set oFolder = Application.ActiveExplorer.CurrentFolder
    For Each item In oFolder.Items
    DoEvents
        If item.EntryID = targetItem Then item.Delete
    Next item
Set oFolder = Nothing
End Sub

Private Sub UserForm_Terminate()
Set KillItem = Nothing
Set oFolder = Nothing
End Sub