Pobranie adresatów z zaznaczonych wiadomości zawierająch w adresie zadaną treść
by vbatools on Jun.22, 2010, under Outlook, Porady
Można użyć darmowego programu CodeTwo Outlook Export i zapisać adresu do pliku, który następnie otworzyć plik Excelem i filtrując wyeksportowane adresy.
Jednakże czasem nie można nic instalować i jedynym rozwiązaniem jest makro.
Uruchomić go można w developerze VBA (Alt+F11) w sekcji module.
Jeśli nie ma się doświadczenia polecam przeczytać artykuł Instalacja i uruchamianie makr.
Oczywiście dla wielkich obszarów makro to będzie wykonywać się długo. .. aż do komunikatu ukończenia exportu.
Realizacja jego jest na podstawie zaznaczonych wiadomości (tak jest ono bardziej uniwersalne), a zaznaczenie wszystkich wiadomości realizuje się po przez (Alt+A).
Option Explicit
Sub Zapisz_adresy_email_dla_zaznaczonych_wiadomosci_zawierajace_tresc()
'MVP OShon from VBATools.pl
If Application.ActiveExplorer.CurrentFolder.DefaultItemType <> 0 Then Exit Sub
Dim oMailItem As MailItem
Dim oRecipients As Recipients
Dim oRecipient As Recipient
Dim item As MailItem
Dim MailAdres, oReply, oRecipients2, oRecip
Dim adresy$, adres$, zgoda$
Dim NoDupes As New Collection
Dim I&, J&, Swap1, Swap2, slowo$, plik$
plik = "c:Tempadresy.txt"
slowo = LCase(InputBox("Podaj treść jaka powinna znajdować się w pobranych adresach email", _
"Podaj część szukanego adresu"))
If Len(slowo) = 0 Then _
MsgBox "Brak danych wyszukania", vbCritical, " Informacja o błędzie": Exit Sub
On Error Resume Next
For I = 2 To UBound(Split(plik, ""))
MkDir Split(plik, "")(I - 1)
Next I
For Each item In Application.ActiveExplorer.Selection
DoEvents
Set MailAdres = item
Set oReply = item.Reply
Set oRecipients2 = oReply.Recipients
'adresy DO
For Each oRecip In oRecipients2
NoDupes.Add LCase(oRecip.Address)
Next oRecip
'adresy DW
For I = 1 To MailAdres.Recipients.Count
NoDupes.Add LCase(MailAdres.Recipients(I).Address)
Next I
If Not MailAdres Is Nothing Then Set MailAdres = Nothing
If Not oReply Is Nothing Then Set oReply = Nothing
If Not oRecipients2 Is Nothing Then Set oRecipients2 = Nothing
Next item
On Error GoTo ErrMessage
For I = 1 To NoDupes.Count - 1
DoEvents
For J = I + 1 To NoDupes.Count
If NoDupes(I) > NoDupes(J) Then
Swap1 = NoDupes(I)
Swap2 = NoDupes(J)
NoDupes.Add Swap1, Before:=J
NoDupes.Add Swap2, Before:=I
NoDupes.Remove I + 1
NoDupes.Remove J + 1
End If
Next J
Next I
Set oMailItem = Application.CreateItem(olMailItem)
Set oRecipients = oMailItem.Recipients
adres = ""
If FileExists(plik) = False Then
Open "C:Tempadresy.txt" For Output As #1
Else
Open "C:Tempadresy.txt" For Append As #1
zgoda = MsgBox("Plik " & plik & " istnieje" & _
vbCr & "Czy dodać adresy do istniejącego pliku?", _
vbMsgBoxSetForeground + vbQuestion + vbYesNo, " Export adresów")
If zgoda = vbNo Then MsgBox "Przerwanie operacji ", vbInformation: Exit Sub
End If
For J = 1 To NoDupes.Count
DoEvents
If adres = NoDupes(J) Then GoTo nastepny
If NoDupes(J) Like "*" & slowo Or _
NoDupes(J) Like slowo & "*" Or _
NoDupes(J) Like "*" & slowo & "*" Then _
Print #1, NoDupes(J)
adres = NoDupes(J)
nastepny:
Next J
Close #1
If FileLen(plik) = 0 Then
Kill plik
MsgBox "Brak adresów zawierających: " & slowo, vbInformation, " Informacja dodatkowa VBATools.pl"
Else
MsgBox "Adresy email z zaznaczonych wiadomości zostały zapisane w pliku " & plik, _
vbInformation, " Informacja dodatkowa"
End If
ErrExit:
On Error Resume Next
If Not oMailItem Is Nothing Then Set oMailItem = Nothing
If Not oRecipients Is Nothing Then Set oRecipients = Nothing
Exit Sub
ErrMessage:
MsgBox "Błąd procedury " & Err.Number & vbCr _
& Err.Description, vbExclamation, " Informacja o błędzie"
GoTo ErrExit
End Sub
Private Function FileExists(FilePath As String) As Boolean
On Error GoTo blad
FileExists = Len(Dir(FilePath, vbDirectory Or vbHidden Or vbSystem)) > 0
Exit Function
blad:
FileExists = False
End Function
(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.