Zaznaczenie kategorią kontaktów wg listy adresów do usunięcia

by vbatools on Dec.20, 2011, under Outlook, Porady

Częstym działaniem marketingowym jest realizacja wysyłek reklamowych drogą E-mail. Dla adresów, które zgłoszone przez serwer jako “adresat nieznany” jest przygotowana lista. Użytkownik aby uaktualnić potencjalnie zainteresowaną grupę odbiorców musi wykonać aktualizację bazy i zaznaczyć lub usunąć tych adresatów, którzy znajdą się opisanej liście. Oczywiście lista taka może być pochodną innego działania, natomiast aby przedstawić działanie kodu przyjmijmy sobie taką hipotetyczną sytuację.

Załóżmy iż lista adresów do wyłączenia będzie zapisana jako plik TXT. Adres po adresie kolejno w każdej linii 1 adres.

W poniższym kodzie możemy zauważyć iż metodą open file for pobierane są adresy do kolekcji, a następnie po przypisaniu do zmiennej lokalizacji folderu książki adresowej na której dotyczy działanie, realizowane jest w pętlach dopasowanie zapamiętanego adresu względem obiektów tego foldera. W przypadku zgodności, takiemu kontaktowi przypisana jest kategoria czerwona. Można w tym przypadku mówić o grupie wg kategorii. Dla list dystrybucyjnych kontakt z listy zostaje wyłączony, ponieważ jako element listy nie może on zostać wyróżniony.

Sub wylacz_adresatow()
'MVP OShon from VBATools.pl
Const plik$ = "c:\TempAdresy.txt"  '<- zmień tą ścieżkę na inną dla pliku z adresami.
Dim x&, y&, z&, pobrany$, F%: F = FreeFile()
Dim tabl As New Collection
On Error GoTo brak_pliku
Open plik For Input As #F
 Do While Not EOF(F)
 Line Input #F, pobrany
 tabl.Add pobrany
 Loop
Close #F
On Error GoTo 0

Dim oFolder As MAPIFolder
Dim oKontakt As ContactItem, oLista As DistListItem
Set oFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

For y = 1 To tabl.Count
DoEvents
 For x = 1 To oFolder.Items.Count
   Select Case oFolder.Items(x).Class
   Case 40
   Set oKontakt = oFolder.Items(x)
   With oKontakt
    If LCase(.Email1Address) = LCase(tabl.item(y)) Or _
     LCase(.Email2Address) = LCase(tabl.item(y)) Or _
     LCase(.Email3Address) = LCase(tabl.item(y)) Then
     .Categories = "Kategoria czerwona"
     .Save
     Exit For
    End If
   End With
 Case 69
  Set oLista = oFolder.Items(x)
  For z = oLista.MemberCount To 1 Step -1
   If LCase(oLista.GetMember(z).Address) = LCase(tabl.item(y)) Then _
    oLista.RemoveMember LCase(oLista.GetMember(z))
  Next z
  oLista.Save
 End Select
 Next x
Next y
Set oFolder = Nothing
Set oKontakt = Nothing
Set oLista = Nothing
MsgBox "Przerobiono " & y & " adresów.", vbInformation, "VBATools.pl"
Exit Sub
brak_pliku:
MsgBox "Brak dostępu do pliku: " & plik & "!" & vbCr & _
 "Sprawdź ścieżkę zapisu adresów do wyłączenia.", vbExclamation, "VBATools.pl"
End Sub

Dla większej ilości adresów do rozpoznania (ok >= 500) zaleca się poniższą procedurę. Wykonuje ona działanie tylko w obrębie kontaktów (bez listy dystrybucyjnej).

Sub wylacz_adresatow2()
'MVP OShon from VBATools.pl
Const plik$ = "c:\TempAdresy.txt"  '<- zmień tą ścieżkę na inną dla pliku z adresami.
Dim y&, pobrany$, F%: F = FreeFile()
Dim tabl As New Collection, sprawdz$
On Error GoTo brak_pliku
Open plik For Input As #F
 Do While Not EOF(F)
  Line Input #F, pobrany
  tabl.Add pobrany
 Loop
Close #F
On Error GoTo 0

Dim oFolder As MAPIFolder
Dim oKontakt As ContactItem, oLista As DistListItem
Set oFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

For y = 1 To tabl.Count
DoEvents
 sprawdz = """" & tabl.item(y) & """"
 Set oKontakt = oFolder.Items.Find("[Email1Address] =" & sprawdz & " or " & _
 "[Email2Address] =" & sprawdz & " or [Email3Address] =" & sprawdz & "")

 While Not oKontakt Is Nothing
  With oKontakt
   .Categories = "Kategoria czerwona"
   .Save
  End With
  Set oKontakt = oFolder.Items.FindNext()
 Wend
 Set oKontakt = Nothing
Next y
MsgBox "Przerobiono " & y & " adresów." & vbCr & _
 "Sprawdź ścieżkę zapisu adresów do wyłączenia.", vbInformation, "VBATools.pl"
Set oFolder = Nothing
Set oKontakt = Nothing
Set oLista = Nothing
Exit Sub
brak_pliku:
MsgBox "Brak dostępu do pliku: " & plik & "!" & vbCr & _
 "Sprawdź ścieżkę zapisu adresów do wyłączenia.", vbExclamation, "VBATools.pl"
End Sub