Tworzenie własnego programu - Lekcja 1. Usunięcie duplikatów

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 On
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
        clmX = .ColumnHeaders.Add(, , "Utworzono", .Width / 6.02)
        clmX = .ColumnHeaders.Add(, , "Nadawca", .Width / 4)
        clmX = .ColumnHeaders.Add(, , "Rozmiar [kb]", .Width / 10)
        clmX = .ColumnHeaders.Add(, , "Temat", .Width / 2)
        clmX = .ColumnHeaders.Add(, , "EntryID", .Width / 2)
        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
    oFolder = Application.ActiveExplorer.CurrentFolder
    For Each item In oFolder.Items
        DoEvents
        On Error Resume Next
        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
    itmX = Nothing
    Delete_d.Enabled = True
    Anuluj.Enabled = True
    Wielkosc.Enabled = True
End Sub
Private Sub Delete_d_Click()
    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$)
    oFolder = Application.ActiveExplorer.CurrentFolder
    For Each item In oFolder.Items
        DoEvents
        If item.EntryID = targetItem Then item.Delete
    Next item
    oFolder = Nothing
End Sub
Private Sub UserForm_Terminate()
    KillItem = Nothing
    oFolder = Nothing
End Sub

Dodaj Tworzenie własnego programu - Lekcja 1. Usunięcie duplikatów Tworzenie własnego programu - Lekcja 1. Usunięcie duplikatów

wyświetleń: 11865