VBA Tools

Porada dotyczy: MS Outlook 2007/10

Ze względu na powszechną możliwość korzystania z darmowych kont pocztowych, wiele osób decyduje się na utrzymywanie i synchronizacje wiadomości z wielu skrzynek pocztowych. W Outlooku 2007/10 mamy możliwość wyboru konta przed wysłaniem wiadomości (rys1).

Rys 1. Wybór konta podczas edycji wiadomości pocztowej.

Niestety często zdarza się iż w czasie pracy z aplikacją zapominamy ustawić odpowiednie konto dla nadawanej wiadomości i orientujemy się o błędzie już po fakcie. Można zapobiec temu opóźniając nadanie wiadomości stosowną regułą (proces opisany w innym artykule) i wyedytować ją zanim zostanie wysłana.

Poniższa procedura przedstawia alternatywny sposób odpytujący użytkownika co do wyboru konta.

Rys 2. Wybór konta podczas po wysłaniu wiadomości.

W przypadku kiedy użytkownik wpisze w przedstawione pow okno (rys2) wartość błędną, wiadomość nie zostanie wysłana czym zostanie poinformowany stosownym komunikatem.

Poniżej przestawiony kod realizuje opisane założenie:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'MVP Shon Oskar - VBATools.pl
 If Item.Class = 43 Then
 Dim objMailItem As MailItem, ChangeMail As MailItem
 Dim olNS As Outlook.Namespace
 SET olNS = Application.GetNamespace("MAPI")
 Dim choose$, list$, x&

 For x = 1 To olNS.Accounts.Count
 list = list & x & " -" & olNS.Accounts.Item(x).DisplayName & vbCr
 Next x
 choose = InputBox("Wybierz numer konta z poniższej listy:" & vbCr & list, _
 "Nadawanie z wybranego konta VBATools.pl", 1)

 If Len(choose) = 0 Then Cancel = True
 If IsNumeric(choose) = True Then
 If choose > x Then GoTo error
 Set objMailItem = Item
 With objMailItem
 Set ChangeMail = .Copy
 .Delete
 Cancel = True
 End With
 With ChangeMail
 .SendUsingAccount = olNS.Accounts.Item(choose)
 .Save
 .Send
 End With
 Else
error:
 Cancel = True
 MsgBox "Nie wybrano prawidłowo numeru konta", vbExclamation, _
 "Nadawanie z wybranego konta VBATools.pl"
 End If
 Set ChangeMail = Nothing
 Set objMailItem = Nothing
 Set olNS = Nothing
 End If
End Sub

Powyżej przedstawioną procedurę umieszczamy w klasie „ThisOutlookSesion”.

Po wstawieniu kodu należy zapisać repozytorium oraz zresetować aplikacje sprawdzając czy procedura zadziała.

Można też przypisać nr konta na stałe zamiast zmiennej (choose) wstawiając cyfrę konta blokując tym sposobem możliwość wysyłania innym kontem (np nowo skonfigurowanym).

Sub lista_kont()
 Dim olNS As Outlook.NameSpace
 Set olNS = Application.GetNamespace("MAPI")

 Dim x&
 For x = 1 To olNS.Accounts.Count
 Debug.Print x & " - " & olNS.Accounts.Item(x).DisplayName
 Next x
End Sub

Pow lista kont jaką można uzyskać w oknie immediate [Ctrl+g]

2012-03-09 Zmodyfikowałem kod ponieważ okazało się że poprzednio przedstawiony zmieniał nazwę konta i tak przedstawiał w folderze elementy wysłane, jednakże poczta zostawała wysłana z pierwotnego konta. Nie jest wykluczone ze to niedopatrzenie zostanie poprawione w następnych wersjach Outlooka.

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