VBATools

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

by 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

Pow. kod należy osadzić w developerze Outlooka [Alt+F11] MenuInsertModule i uruchomić [F5] lub z Outlooka [Alt+F8]

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

:, , , , , ,

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Joanna Subik
Profile picture of Karol Stilger
Profile picture of Anorak
Profile picture of marcinmachalowski
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała