VBATools

Poniższa procedura pomocna może być w przypadki kiedy użytkownik posiada publiczne foldery. Za jednym zamachem chce wysłać kopie wiadomości na serwer w postaci obiektu, bez nadawania konkretnego adresata.

Procedura też możne być pomocna w czynności archiwizacyjnej, realizowanej w postaci pozostawienia śladu poza elementy wysłane, bez konieczności przenoszenia elementu myszą.

Wiadomości wysłane:

Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As  Boolean)
'MVP OShon from VBATools.pl
 Dim oMail As MailItem
 Dim oFolder As MAPIFolder
 Dim olNs As Outlook.NameSpace
 Set olNs = Application.GetNamespace("MAPI")

 Set oMail = Item
 If oMail Is Nothing Then Exit Sub

 If MsgBox("Czy wykonać kopię wiadomość poza ''Elementy  wysłane''?", vbYesNo) = vbYes Then
 Dim bExitFor: bExitFor =  False
 Do
 Set oFolder = olNS.PickFolder
 If oFolder  Is Nothing Then Exit Sub

 If  oFolder.DefaultItemType <> 0 Then
 MsgBox  "Wpisanie inf do folderu " & chr(34) & oFolder.Name & chr(34) & " nie jest możliwe." & vbCr _
 & "Wybierz folder  poczty!", vbExclamation, " Informacja o błędzie VBATools.pl"
 Set  oFolder = olNS.GetDefaultFolder(olFolderOutbox)
 Else
 bExitFor = True
 End  If
 Loop While Not bExitFor

 Set  oFolder = olNS.GetFolderFromID(oFolder.EntryID,  oFolder.StoreID)
 On Error Resume Next 'ponieważ  wiadomośc nie może być usunięta w locie to bedzie przekopiowana
 oMail.Move oFolder
 On Error GoTo 0
 Else
 Exit Sub
 End If
 Set oMail = Nothing
 Set oFolder = Nothing
 Set olNS = Nothing
End Sub

Oczywiście makro to można rozbudować tak aby wywoływane było tylko w tedy gdy temat lub adres email, treść wiadomości etc, posiadała by zadeklarowany ciąg znaków.

Spotkałem się też z chęcią przekierowywania każdej nadchodzącej poczty do osobno wskazanego folderu. Dość oryginalny sposób, zwłaszcza gdy użytkownik odbiera większą ilość poczty. Na dłuższy etap uciążliwy. Uważam że skonstruowanie kodu tak aby można było go użyć jako reguła może być uruchomiona dla pewnego rodzaju określonych nadawców (np po domenie).

Wiadomości odebrane:

Sub ExportIncomingMailToSelectedFolder(item As MailItem)
'MVP OShon from VBATools.pl
Dim oFolder As MAPIFolder
Dim olNs As Outlook.NameSpace
Set olNs = Application.GetNamespace("MAPI")
 If MsgBox("Czy przenieść pocztę od " & Chr(34) & item.SenderName & Chr(34) & _
 " do wskazanego folderu?", vbYesNo) = vbYes Then
 Dim bExitFor: bExitFor = False
 Do
 Set oFolder = olNs.PickFolder
 If oFolder Is Nothing Then Exit Sub

 If oFolder.DefaultItemType <> 0 Then
 MsgBox "Wpisanie inf do folderu " & Chr(34) & oFolder.Name & Chr(34) & _
 " nie jest  możliwe." & vbCr & "Wybierz folder  poczty!", _
 vbExclamation, " Informacja o błędzie VBATools.pl"
 Set oFolder = olNs.GetDefaultFolder(olFolderOutbox)
 Else
 bExitFor = True
 End If
 Loop While Not bExitFor

 Set oFolder = olNs.GetFolderFromID(oFolder.EntryID, oFolder.StoreID)
 On Error GoTo blad
 item.Move oFolder
 End If
koniec:
 Set oFolder = Nothing
 Set olNs = Nothing
Exit Sub
blad:
MsgBox "Błąd procedury ExportIncomingMailToSelectedFolder." & vbCr & vbCr & _
 Err.Number & " " & Err.Description, vbExclamation, _
 " Informacja o błędzie VBATools.pl"
GoTo koniec
End Sub

Aby temu zapobiec należy umieścić w sekcji klasy ThisOutlookSession poniższe makro. Procedura zadziała po zapisie i restarcie Outlooka.