Microsoft Outlook troubleshooting

Częstym działaniem marketingowym jest wysyłanie reklam drogą E-mail. Dla adresów, które zgłoszone są przez serwer jako „adresat nieznany” przygotowana jest 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ę na wspomnianej liście (oczywiście taka lista może być także skutkiem innego działania).

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

W poniższym kodzie metodą open file for pobierane są adresy do kolekcji, a następnie po przypisaniu do zmiennej lokalizacji folderu książki adresowej, której dotyczy działanie, realizowane jest w pętlach dopasowanie zapamiętanego adresu do obiektów tego foldera. W przypadku zgodności, takiemu kontaktowi przypisana jest kategoria czerwona. 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 As String = "c:\Temp\Adresy.txt" '<- zmień tą ścieżkę na inną z plikiem 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

Sub wylacz_adresatow2()
'MVP OShon from VBATools.pl
Const plik As String = "c:\Temp\Adresy.txt" '<- zmień tą ścieżkę na inną z plikiem z adresami.
Dim x&, y&, z&, 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

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 As String = "c:\Temp\Adresy.txt" '<- zmień tą ścieżkę na inną z plikiem z adresami.
Dim x&, y&, z&, 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

Powyższy kod należy osadzić w developerze Outlooka [Alt+F11] Menu\Insert\Module i uruchomić [F5] lub z Outlooka [Alt+F8].

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.