Microsoft Outlook troubleshooting

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.
 
Usunięcie duplikatu
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.

Komentarze

Komentarze
Samson
Samson 2014-03-28 09:26:08
Witam, Skrypt nie działa, niestety nie jest wytłumaczone co z plikiem Kill_Duplicate.frx. Miło, że ktoś poświęca czas aby pomóc innym, ale niestety jest jak zwykle, poprostu coś nie działa.
OShon
OShon, VBATools.pl 2014-07-04 10:36:38
Co nie działa? Proszę o takie informacje na Forum. W której linii jest błąd. Forma gotowa do importu, pow. link działa. Przypominam że należy mieć zainstalowaną kontrolkę mscomctl.ocx
warkcd
warkcd, nd 2014-12-07 03:06:24
Ja potwierdzam wszystko działa jak należy, dziękuje twórcy za źródło nauki i gotowe rozwiązanie
Piotrekop
Piotrekop 2015-08-13 11:59:05
przydałoby się bardziej obrazowo to wytłumaczyć a nie bełkot programistów.
Piotrekop
Piotrekop 2015-08-14 02:28:11
nie działa w outlook 2013. Nadal nie wiadomo jak i gdzie umieścić plik z rozszerzeniem .frx? Pojawia się komunikat o błędzie i nie można go załadować.
Oskar Shon
Oskar Shon, VBATools.pl 2015-08-17 15:43:05
"...na miejsce drzewa projektu" co zostało opisane pow. Artykuły służą do pogłębienia wiedzy, co nie zwalnia od samodzielnego myślenia i szukania rozwiązań w literaturze.