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

Recently Active Members

Profile picture of vbatools
Profile picture of Joanna Subik
Profile picture of Karol Stilger
Profile picture of Anorak
Profile picture of marcinmachalowski
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała