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

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 makra odbywa się na podstawie zaznaczonych wiadomości (tak jest ono bardziej uniwersalne), a zaznaczenie wszystkich wiadomości realizuje się po przez (Alt+A).

Option Explicit On

Sub Zapisz_adresy_email_dla_zaznaczonych_wiadomosci_zawierajace_tresc()

    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:\Temp\adresy.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()

            MailAdres = item

            oReply = item.Reply

            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 MailAdres = Nothing

            If Not oReply Is Nothing Then oReply = Nothing

            If Not oRecipients2 Is Nothing Then 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

        oMailItem = Application.CreateItem(olMailItem)

        oRecipients = oMailItem.Recipients

        adres = ""

        If FileExists(plik) = False Then

    Open "C:\Temp\adresy.txt" For Output As #1

        Else

    Open "C:\Temp\adresy.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")

        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 oMailItem = Nothing

        If Not oRecipients Is Nothing Then 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(ByVal 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

Aby osadzić procedurę "Zapisz_adresy_email_dla_zaznaczonych_wiadomosci_zawierajace_tresc" pod przyciskiem w menu MS Outlook, polecam uwadze ten artykuł.

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.