Wyszukiwanie adresów z pola “DO”, “DW” i zapis do pliku
by vbatools on Jul.03, 2010, under Outlook, Porady
Jeden z forumowiczów zwrócił się z prośbą o wyszukanie adresów email zawierających słowo w adresie pocztowym. Nie wykluczone iż dotyczy to zapisu konkretnych pracowników określonej w zadaniu domeny.
Czynność taką można wykonać przy pomocy darmowego programu CodeTwo Outlook Export i zapisać adresu do pliku, który następnie otworzysz Excelem i przefiltrujesz wyeksportowane adresy.
Jednakże forumowicz nie mógł nic instalować na ograniczonym prawami koncie. Makro było jedynym rozwiązaniem.
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:\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
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:\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 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.