Przesyłanie dalej jednym przyciskiem
by vbatools 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.
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ę
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.