VBATools

Przesyłanie dalej jednym przyciskiem

by on Jul.05, 2011, under Outlook, Porady

W tej poradzie chciałem opisać przykład jaki natknąłem się na Outlook.pl. Chodziło w nim o to aby przyspieszyć przesyłanie wiadomości do adresata.

Nie było by niczego niezwykłego w takim zamiarze, gdyby nie fakt braku sprecyzowania warunków po jakich miały być rozpoznany odbiorca.

Zwykle realizując regułę sugerujemy się treścią wiadomości, adresatem wiadomości lub tematem. W tym przypadku można przenieść wiadomość do folderu oraz określić adres osoby, która miało by dostać jej kopie.

OL_Reguła_przeslij_dalej

Rys. 1. Reguła przekierowania i FW wiadomości

Jak rozwiązać sprawę kiedy jest brak możliwości odniesienia się do jakichkolwiek danych. Nie wykluczone że z kontekstu treści operator decyduje komu go przesłać.

Normalne postępowanie więc w tym przypadku polega na otwarciu wiadomości, wciśnięciu “Prześlij dalej” i wpisaniu adresata wraz z naciśnięciem [Ctrl+Enter] lub “Wyślij”.

Część z tych czynności nie da się przyśpieszyć, choć nie koniecznie. Poniższy kod zainstalowany w module developera VBA Outlooka i uruchomiony z podpiętego przycisku menu* lub po przez wywołanie procedury [Alt+F8] realizuje ten cel.

Należy przygotować tyle procedur ile adresatów:

Sub wyslij_do_olka() 'nazwa względem adresata
'MVP OShon from VBATools.pl
Dim Addres_mailowy$: Addres_mailowy = "olek@mail.pl" 'zmiana adresu nadawcy
If Not Addres_mailowy Like "*@*.*" Then GoTo blad
Dim MyItem As MailItem

 On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
 Set MyItem = ActiveExplorer.Selection.Item(1)
 MyItem.Display
Case "Inspector"
 Set MyItem = ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If MyItem Is Nothing Then
MsgBox "Wpierw wskaż lub otwórz wiadomość " & _
 "do którą chcesz wysłać dalej!", vbExclamation, "VBATools.pl"
GoTo koniec
End If

Call Wyslij_dalej(MyItem, Addres_mailowy)
MyItem.Close olDiscard
koniec:
Set MyItem = Nothing
Exit Sub
blad:
MsgBox "Błędnie określony adres nadawcy" & _
 "popraw adres w kodzie!", vbExclamation, "VBATools.pl"
GoTo koniec
End Sub

Private Sub Wyslij_dalej(Item As Outlook.MailItem, adres As String)
Dim Odpowiedz As MailItem
Set Odpowiedz = Item.Forward
With Odpowiedz
 .To = adres
 .Send
End With
Set Odpowiedz = Nothing
End Sub

*Osadzenie przycisków do procedur w menu:

2007 = Prawy klawisz na Menu/Dostosuj/przeciągnij procedurę na pasek/Zmień ikonkę

OL_Reguła_przeslij_dalej_przycisk

2010 = Prawy klawisz na menu wstęgiDostosuj…szybki dostępWybierz poleceniaMakra listaDodajModyfikuj -zmiana ikony

Dodatkowo powyższą procedurę można połączyć z przeniesieniem do przygotowanego wcześniej folderu (zwykle takie połączenie jest realizowane regułą), dodając parę linijek oraz dodają funkcję wyszukującą docelowy folder:

Sub wyslij_do_oskara()                                    '<-popraw nazwę względem adresata
'MVP OShon from VBATools.pl
Dim Addres_mailowy$: Addres_mailowy = "oskar@mail.pl"     '<-tu popraw adres
Dim folderPath$: folderPath = "\Foldery osobisteAneta"    '<- tutaj zmieniasz folder lub dopisujesz nową ścieżkę.
If Not Addres_mailowy Like "*@*.*" Then GoTo blad
Dim MyItem As MailItem

On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set MyItem = ActiveExplorer.Selection.Item(1)
MyItem.Display
Case "Inspector"
Set MyItem = ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If MyItem Is Nothing Then
MsgBox "Wpierw wskaż lub otwórz wiadomość " & _
"do którą chcesz wysłać dalej!", vbExclamation, "VBATools.pl"
GoTo koniec
End If

Call Wyslij_dalej(MyItem, Addres_mailowy)
'MVP OShon from VBATools.pl
MyItem.Close olDiscard

On Error GoTo blad2
MyItem.Move GetFolder(folderPath)
koniec:
Set MyItem = Nothing
Exit Sub
blad:
MsgBox "Błędnie określony adres nadawcy" & _
"popraw adres w kodzie!", vbExclamation, "VBATools.pl"
Resume koniec
Exit Sub
blad2:
MsgBox "Wiadomości nie przeniesiono!" & vbcr _
& "Brak folderu " & folderPath, vbExclamation, "VBATools.pl"
Resume koniec
End Sub

Function GetFolder(ByVal FolderPath As String) As Outlook.folder
'via MS help
 Dim TestFolder As Outlook.folder
 Dim FoldersArray As Variant
 Dim i As Integer

 On Error GoTo GetFolder_Error
 If Left(FolderPath, 2) = "\" Then
 FolderPath = Right(FolderPath, Len(FolderPath) - 2)
 End If
 'Convert folderpath to array
 FoldersArray = Split(FolderPath, "")
 Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
 If Not TestFolder Is Nothing Then
 For i = 1 To UBound(FoldersArray, 1)
 Dim SubFolders As Outlook.Folders
 Set SubFolders = TestFolder.Folders
 Set TestFolder = SubFolders.Item(FoldersArray(i))
 If TestFolder Is Nothing Then
 Set GetFolder = Nothing
 End If
 Next
 End If
 'Return the TestFolder
 Set GetFolder = TestFolder
 Exit Function

GetFolder_Error:
 Set GetFolder = Nothing
 Exit Function
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