
Aby dobrze poznać język VBA dobrym rozwiązaniem jest napisanie programu i poznanie jego działania.
Lekcja 1. Usunięcie duplikatów.
Jeśli zastanawiacie się jak wykonać prosty program, np. usuwający duplikaty poczty przychodzącej, to zapraszam do przeczytania poniższego artykułu.
Głównymi parametrami, jakie klasyfikują obiekty typu email są:
- Data utworzenia wiadomości
- Nadawca (Adres SMTP)
- Rozmiar wiadomości (wraz z załącznikami)
- Temat wiadomości
- Nr EntryID (indywidualny nr obiektu, posłuży do usunięcia duplikatu)
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:
Option Explicit
Sub Wywolanie()
Kill_Duplicate.Show
End Sub
Aby bardziej zautomatyzować proces uruchamiania można dodać do paska menu dodatkową ikonkę wywołującą program. Artykuł dotyczący tego procesu jest umieszczony pod tym linkiem.
Uruchomienie powyższej procedury, spowoduje wywołanie formy (Rys.1.) składającej się z: listy elementów, paska postępu (oba z pakietu biblioteki mscomctl.ocx), trzech przycisków, checkboxa oraz etykiety, głownie stosowanej do opisów elementów wstawionych w kształtkę formy.

Rys.1. Ekran programu zestawiający wiadomości do porównania.
Poniżej przedstawiony zbiór procedur znajduje się w kodzie formy:
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
Proces usunięcia duplikatów poczty, umieszcza obiekty w folderze „Elementy usunięte”, skąd mogą być przeniesione na powrót do pierwotnego folderu (z wyłączeniem uruchomienia procedury w folderze „Elementy usunięte”).
W przypadku niedziałania kodu należy sprawdzić, czy w systemie operacyjnym posiadamy wymaganą i zarejestrowaną bibliotekę obiektów „Microsoft Windows Common Controls 6.0 (SP6)” Menu/Tools/References. Program został sprawdzony i jest kompatybilny z wersjami 2000-2007 MS Outlook.
Dla tych, którym pisanie kodu sprawia trudności polecam gotową aplikację COM do kasowania duplikatów poczty. Nie tylko co do faktycznych dubli, ale wersji identycznych kontekstowo (np przesłanych przez aliasy).
MVP Shon Oskar – VBATools.pl
Jeśli masz pytania dot. tego artykułu zapraszam na Forum
Skonfiguruj swój pakiet dodatków do Excela, Worda, PowerPointa i Outlooka
© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.