VBATools

Wyszukiwanie adresów z pola “DO”, “DW” i zapis do pliku

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

:, , , ,

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
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