Tworzenie własnego programu - Lekcja 4. Dodawanie adresów email

autor OShon 2011-05-11 14:09:00 w Makra
tagi: adresy email, eksport, kontakty, książka adresowa, makro, MS Outlook, vb, 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.

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

Dodaj Tworzenie własnego programu - Lekcja 4. Dodawanie adresów email Tworzenie własnego programu - Lekcja 4. Dodawanie adresów email

Wszystkie daty podane w CEST (UTC +2:00)