Microsoft Outlook troubleshooting


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

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
           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
            Open "C:\Temp\adresy.txt" For Append As #1
        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ł.

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.