
Tworzenie własnego programu - Lekcja 4. Dodawanie adresów email
tagi: vb, MS Outlook, makro, książka adresowa, kontakty, eksport, adresy email, wysłane, zapisać
Kolejna lekcja odpowiada na dość często zadawane pytanie: „Czy można dodać adresy email z poczty przychodzącej i wychodzącej Outlooka”. Od razu na wstępie należy uświadomić sobie, iż takie działanie nie jest dość rozsądne z punktu widzenia biznesowego. Wiadomość, którą otrzymujemy posiada adres email oraz opcjonalną nazwę wyświetlaną - jest ona dowolnie konfigurowana przez posiadacza konta i może być nią słowo klucz, przezwisko, nazwo firmy czy instytucji lub jakikolwiek inny logiczny bądź nie zlepek znaków. Gdy w książce adresowej użytkownik posiada wiele niekonkretnych kontaktów może utrudnić mu to normalną pracę z programem.
Mechanizm, jaki został przygotowany w czwartej lekcji zaspokaja oczekiwania pytających, dzięki wyświetleniu interfejsu z adresami email dla zaznaczonej wcześniej grupy wiadomości. Pokazuje on czy adresy te już są częścią wybranej książki adresowej i umożliwia ich prostą implementację. Rozszerzeniem funkcjonalności jest możliwość eksportu danych do listy dystrybucyjnej, pliku tekstowego lub wyświetlenie ich w oknie do edycji, z podziałem adresów od/do. Aby upewnić się czy kontakty, które mechanizm odnalazł w książce są właściwe można wywołać je klikając dwukrotnie na rekordzie kontaktu w interfejsie rozpoznania.
Tym razem jedyną możliwością implementacji kodu będzie pobranie gotowego interfejsu (choć wolałbym abyście zgłębiali kod a nie kopiowali gotową pracę). Po rozpakowaniu pobranego pliku osadzić go na miejsce drzewa projektu (analogicznie jak w lekcjach poprzednich).
Moduł wywołujący formę interfejsu tym razem jest bardziej złożony, ponieważ zawiera on funkcje API niezbędną do wywołania katalogu docelowego dla zapisu adresów do pliku:
Option Explicit Declare Function SHGetPathFromIDList Lib "Shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "Shell32.dll" _ Alias "SHBrowseForFolderA" (ByVal lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Function GetDirectory(Optional msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(msg) Then bInfo.lpszTitle = "Wybieranie katalogu." Else bInfo.lpszTitle = msg End If bInfo.ulFlags = &H1 x = SHBrowseForFolder(bInfo) path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, xhr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function Sub Zanzaczone_Kontakty_zapisz() Add_Mailing_adreses.Show(0) End Sub
Uruchomienie powyższej procedury, spowoduje wywołanie formy (Rys.1.) składającej się z: dwóch pól tekstowych, sześciu przycisków, jednego paska postępu oraz pola ListView (oba z pakietu biblioteki mscomctl.ocx), czterech checkboxów, czterech przycisków radio oraz dwóch etykiet i dwóch ramek oddzielających wybór opcjonalnych elementów exportu.
Rys 1. Interfejs programu importującego kontakty.
Cały kod formy zostanie w tej lekcji pominięty, ponieważ mechanizm jest dość złożony. Poniżej zostaną przytoczone tylko najważniejsze jego fragmenty
Private Sub Adress_Add_Click() If Me.Adress_list.ListItems.Count < 1 Then _ MsgBox "Zaznacz wiadomosci pocztowe a następnie uruchom " & XXXX & _ "Więcej opcji\Czytaj ponownie" & XXXX, vbExclamation, APPNAME: Exit Sub strFolderID = GetSetting(APPNAME, "Settings", "Zapis_kontaktow_Folder", "") strStoreID = GetSetting(APPNAME, "Settings", "Zapis_kontaktow_Store", "") With Application.GetNamespace("MAPI") If Len(strFolderID) > 0 Then oContactFolder = .GetFolderFromID(strFolderID, strStoreID) Else oContactFolder = .GetDefaultFolder(olFolderContacts) End If End With Adress_list.Visible = True 'do Książki adresowej If Adresy_zapisz_w_ksiazce.Value = True Then tekst = "" With Me.Adress_list For x = 0 To .ListItems.Count - 1 DoEvents If .ListItems.item(x + 1).ListSubItems(3).Text = "NIE" Then If Adresy_zaznaczone.Value = True Then If .ListItems.item(x + 1).Checked = False Then GoTo Do_Ksiazki_Przejdz End If oNewContact = oContactFolder.Items.Add oNewContact.FullName = .ListItems.item(x + 1).Text oNewContact.Email1Address = .ListItems.item(x + 1).ListSubItems(1).Text oNewContact.Body = vbCrLf & "Kontakt wyeksportowany z zaznaczonej poczty" & _ vbCrLf & "Dzięki " & XXXXX & APPNAME & XXXXX oNewContact.Categories = APPNAME oNewContact.Save .ListItems.item(x + 1).ListSubItems(3).Text = "Zapisano" .ListItems.item(x + 1).Checked = False tekst = tekst & .ListItems.item(x + 1).ListSubItems(1).Text & vbCr Do_Ksiazki_Przejdz: End If Next End With If Not oNewContact Is Nothing Then oNewContact = Nothing If Len(Trim(Replace(tekst, vbCr, vbNullString))) > 0 Then MsgBox "Kontakty jakie zostały założone przez mechanizm:" & vbCr _ & tekst, vbInformation, APPNAME Else MsgBox "Nie zapisano żadnych kontaktów", vbExclamation, APPNAME End If 'Do pliku ElseIf Adresy_do_pliku_Path.Text <> "" And Adresy_do_pliku_Plik.Value = True Then On Error GoTo blad_sciezki Open Adresy_do_pliku_Path.Text For Output As #1 On Error GoTo 0 With Me.Adress_list For x = 0 To .ListItems.Count - 1 If Adresy_zaznaczone.Value = True Then If .ListItems.item(x + 1).Checked = False Then GoTo Do_Pliku_Przejdz End If If Adresy_Od.Value = True Then If Adresy_do_pliku_Nazwy = True Then If .ListItems.item(x + 1).ListSubItems(2).Text = "Od" Then _ Print #1, .ListItems.item(x + 1).ListSubItems(1).Text & "," & _ .ListItems.item(x + 1) Else If .ListItems.item(x + 1).ListSubItems(2).Text = "Od" Then _ Print #1, .ListItems.item(x + 1).ListSubItems(1).Text End If End If If Adresy_Do.Value = True Then If Adresy_do_pliku_Nazwy = True Then If .ListItems.item(x + 1).ListSubItems(2).Text = "Do" Then _ Print #1, .ListItems.item(x + 1).ListSubItems(1).Text & "," & _ .ListItems.item(x + 1) Else If .ListItems.item(x + 1).ListSubItems(2).Text = "Do" Then _ Print #1, .ListItems.item(x + 1).ListSubItems(1).Text End If End If Do_Pliku_Przejdz: Next x End With Close #1 MsgBox "Adresy email z zaznaczonych wiadomości zostały zapisane w pliku " & _ Adresy_do_pliku_Path.Text, vbInformation, "Informacja dodatkowa " & APPNAME 'Na ekran ElseIf Adresy_do_pliku_Ekran.Value = True Then tresc.Text = "" With Me.Adress_list For x = 0 To .ListItems.Count - 1 If Adresy_zaznaczone.Value = True Then If .ListItems.item(x + 1).Checked = False Then GoTo Na_Ekran_Przejdz End If If Adresy_Od.Value = True Then If Adresy_do_pliku_Nazwy = True Then If .ListItems.item(x + 1).ListSubItems(2).Text = "Od" Then _ tresc.Text = tresc.Text & .ListItems.item(x + 1). _ ListSubItems(1).Text & "," & .ListItems.item(x + 1) & vbCr Else If .ListItems.item(x + 1).ListSubItems(2).Text = "Od" Then _ tresc.Text = tresc.Text & .ListItems.item(x + 1). _ ListSubItems(1).Text & vbCr End If End If If Adresy_Do.Value = True Then If Adresy_do_pliku_Nazwy = True Then If .ListItems.item(x + 1).ListSubItems(2).Text = "Do" Then _ tresc.Text = tresc.Text & .ListItems.item(x + 1). _ ListSubItems(1).Text & "," & .ListItems.item(x + 1) & vbCr Else If .ListItems.item(x + 1).ListSubItems(2).Text = "Do" Then _ tresc.Text = tresc.Text & .ListItems.item(x + 1). _ ListSubItems(1).Text & vbCr End If End If Na_Ekran_Przejdz: Next x End With With tresc .Top = Adress_list.Top .Height = Adress_list.Height .Visible = True End With Adress_list.Visible = False 'na liste dystrybucyjną ElseIf Adresy_do_Listy_dystrybucyjnej.Value = True Then Dim Message$, nazwa_listy$ Message = "Podaj nazwe dla zakładanej listy dystrybucyjnej." & vbCr _ & "Wszystkie kontakty zgodnie z wybranymi opcjami zostaną podłączone do tej grupy." nazwa_listy = Trim(InputBox(Message, " Tworzenie listy dystrybucyjnej")) nazwa_listy = Replace(nazwa_listy, ";", " ") nazwa_listy = Replace(nazwa_listy, "(", vbNullString) nazwa_listy = Replace(nazwa_listy, ")", vbNullString) If Len(Trim(nazwa_listy)) = 0 Then Exit Sub On Error GoTo ErrMessage oDistList = oContactFolder.Items.Add(olDistributionListItem) With oDistList .DLName = nazwa_listy .Save End With oDistList = oContactFolder.Items(nazwa_listy) oMailItem = Application.CreateItem(olMailItem) oRecipients = oMailItem.Recipients With Me.Adress_list For x = 0 To .ListItems.Count - 1 If Adresy_zaznaczone.Value = True Then If .ListItems.item(x + 1).Checked = False Then GoTo Na_liste_Przejdz End If If Adresy_Od.Value = True Then If .ListItems.item(x + 1).ListSubItems(2).Text = "Od" Then _ oRecipients.Add.ListItems.item(x + 1).ListSubItems(1).Text End If If Adresy_Do.Value = True Then If .ListItems.item(x + 1).ListSubItems(2).Text = "Do" Then _ oRecipients.Add.ListItems.item(x + 1).ListSubItems(1).Text End If Na_liste_Przejdz: Next x End With oRecipients.ResolveAll With oDistList .AddMembers (oRecipients) .Categories = APPNAME .Save .Display (0) End With ErrExit: On Error Resume Next oDistList = Nothing oMailItem = Nothing oRecipients = Nothing End If oContactFolder = Nothing Exit Sub blad_sciezki: MsgBox "Zła ścieżka zapisu pliku", vbCritical, " Informacja o błędzie " & APPNAME Exit Sub ErrMessage: MsgBox "Błąd procedury " & Err.Number & vbCr _ & Err.Description, vbExclamation, " Informacja o błędzie " & APPNAME GoTo ErrExit End Sub Private Sub Ponownie_sprawdz_Click() Adress_list.ListItems.Clear Adress_Add.Visible = False Wiecej.Visible = False Anuluj.Visible = False Author.Visible = False Adress_list.Visible = True tresc.Visible = False Dim MailAdres As MailItem, oReply, oRecipients2, oRecip, ile& With Application.ActiveExplorer If .CurrentFolder.DefaultItemType <> 0 Then Exit Sub ile = .Selection.Count End With ProgressBar1.Top = 294 y = 0 On Error GoTo ErrMessage With Me.Adress_list .Sorted = True .SortKey = 1 .SortOrder = lvwAscending For Each item In Application.ActiveExplorer.Selection DoEvents If item.Class <> 43 Then GoTo opusc MailAdres = item oReply = item.Reply oRecipients2 = oReply.Recipients With .ListItems 'adresy DO If Adresy_Od.Value = True Then For Each oRecip In oRecipients2 itmX = .Add(, , Replace(Trim(oRecip.Name), "'", "")) intCount = intCount + 1 itmX.Tag = "ListItem " & intCount itmX.SubItems(1) = oRecip.Address 'na wypadek jeżeli funcja nie pobierze nazwy obiektu If Len(oRecip.Address) = 0 And InStr(1, oRecip.Name, "@") > 0 Then _ itmX.SubItems(1) = Replace(Trim(oRecip.Name), "'", "") itmX.SubItems(2) = "Od" itmX.SubItems(3) = "No Check" itmX.SubItems(4) = "" itmX.Bold = False itmX = Nothing Next End If 'adresy DW If Adresy_Do.Value = True Then For I = 1 To MailAdres.Recipients.Count itmX = .Add(, , Replace(Trim(MailAdres.Recipients(I).Name), "'", "")) intCount = intCount + 1 itmX.Tag = "ListItem " & intCount itmX.SubItems(1) = MailAdres.Recipients(I).Address If Len(MailAdres.Recipients(I).Address) = 0 And _ InStr(1, MailAdres.Recipients(I).Name, "@") > 0 Then _ itmX.SubItems(1) = Replace(Trim(MailAdres.Recipients(I).Name), "'", "") itmX.SubItems(2) = "Do" itmX.SubItems(3) = "No Check" itmX.SubItems(4) = "" itmX.Bold = False itmX = Nothing Next I End If For I = 1 To .Count If I <= .Count Then If .item(I).ListSubItems(3).Text = "No Check" Then If FindContact(.item(I).ListSubItems(1).Text) = 1 Then .item(I).ListSubItems(3).Text = "TAK" If Len(Entry) > 0 Then .item(I).ListSubItems(4).Text = Entry Else .item(I).ListSubItems(3).Text = "NIE" .item(I).Bold = True .item(I).ListSubItems(3).Bold = True .item(I).Checked = True End If End If End If If I < .Count Then If LCase(.item(I).ListSubItems(1).Text) = _ LCase(.item(I + 1).ListSubItems(1).Text) Then .Remove (I + 1) End If End If Next I End With opusc: y = y + 1 With ProgressBar1 .Visible = True .max = ile .Value = y End With Next .SortKey = 0 End With ProgressBar1.Visible = False Adress_Add.Visible = True Wiecej.Visible = True Anuluj.Visible = True Author.Visible = True Adress_list.Refresh Me.Repaint MailAdres = Nothing oReply = Nothing oRecipients2 = Nothing Exit Sub ErrMessage: MsgBox "Błąd procedury " & Err.Number & vbCr _ & Err.Description, vbExclamation, " Informacja o błędzie " & APPNAME End Sub Private Sub Adresy_zaznaczone_Click() SaveSetting APPNAME, "Settings", "Adresy_zaznaczone", Adresy_zaznaczone End Sub
W kodzie tym przygotowano zapis wyboru opcji do rejestru systemowego tak, aby przy ponownym uruchomieniu interfejsu elementy te pozostały zapamiętane.
W przypadku gdy kod nie działa poprawnie należy sprawdzić czy w systemie operacyjnym posiadamy wymaganą i zarejestrowaną bibliotekę obiektów Microsoft Windows Common Controls 6.0 (SP6) Menu/Tools/Preferences. Program został sprawdzony i jest kompatybilny z wersjami MS Outlook 2k/13.
Jeśli samodzielna budowa tego mechanizmu w swoim developerze Cię przerasta i nie masz ochoty przechodzić przez kolejne lekcje aby zbudować to narzędzie bazując na pow podpowiedziach, to mam dla ciebie miłą wiadomość. Został on przepisany na dodatek COM i jest dostepny w ofercie projktu VBATools.pl. Możesz przeczytać o tym tutaj: "Dodawanie adresów email". Chętnych zapraszam do zapoznania się z dostępnymi rozwiązaniami, które usprawnią twoją pracę w Office.
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.