VBATools

Pobranie adresatów z zaznaczonych wiadomości zawierająch w adresie zadaną treść

by 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.

:, , ,

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