VBATools

Porada dotyczy: MS Excel i Outlook z pakietu Office

Posiadając listę (np. w MS Excel), której to elementy zawierają hiperłącza typu „mailto” z adresami do odbiorców, mamy możliwość po kliknięciu myszą wygenerować wiadomość. Czynność ta jest wygodna w przypadku kiedy ilość generowanych wiadomości przy użyciu tego modelu jest ograniczona, a treść wiadomości różna.

Rys 1. Przykład Hiperlinka w MS Excel

Kliknięty hiperlink otwiera nam nową wiadomość która jest uzupełniona adresem oraz tematem zawartym w hiperlinku. Wygenerowana wiadomość nie zawiera treści to też fakt wyświetlenia jej do edycji jest standardową i jedyną procedurą.

Można przypuszczać iż w przypadku kiedy użytkownik ma konieczność wysyłki wiadomości o standardowej treści można wyłączyć tworzenie wiadomości na korzyść wysłania (bez wyświetlenia) wiadomości. W tym celu niezbędna będzie modyfikacja wpisu rejestru:
Klucz: HKEY_CLASSES_ROOT\mailto\shell\open\command
Zamiast: “C:\PROGRA~1\MICROS~2\Office\OUTLOOK.EXE” -c IPM.Note /m “%1”
Na: “C:\PROGRA~1\MICROS~2\Office\OUTLOOK.EXE” /recycle /m “%1”
W systemach Vista/W7 należy po zmianie ustawień w rejestrze uruchomić komputer ponownie.

W Excelu, gdzie znajdują się hiperlinki w module arkusza wpisujemy poniższą procedurę:

Option Explicit

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'MVP OShon from VBATools.pl
If InStr(1, Target.Address, "mailto") = 0 Then Exit Sub
Dim adres$: adres = Replace(Split(Target.Address, "?")(0), "mailto:", vbNullString)
Dim temat$: temat = Split(Target.Address, "subject=")(1)
Dim wyslano As Boolean
wyslano = Wysylanie_email(adres, temat)
If wyslano = False Then MsgBox "Problemy z wygenerowaniem wiadomości", _
 vbExclamation, "O'Shon VBATools.pl"
End Sub

Function Wysylanie_email(adres$, temat$)
 Dim OutApp As Object
 Dim OutMail As Object

 Set OutApp = CreateObject("Outlook.Application")
 OutApp.Session.Logon
 Set OutMail = OutApp.CreateItem(0)

 With OutMail
 .To = adres
 .Subject = Replace(temat, "%20", " ") 'mailto generuje URLEncode
 .Body = "Tresc wiadomosci"
 '.Display  'wyswietla
 .Send      'wysyła
 '.Save     'zapisuje w roboczych
 End With

 Set OutMail = Nothing
 Set OutApp = Nothing
End Function

(c) Shon Oskar – www.VBATools.pl