Outlook - Quick Folder Move

Per motivi lavorativi ho iniziato ad utilizzare Outlook ( versione 2013 ). Non ho trovato nessuna funzione simile all' Add-Ons Quick Folder Move che utilizzavo con Thunderbird.

Cercando in rete ho trovato vari esempi per poter realizzare una vba Userform che mi permetta di avere una funzionalità simile.

Procedere in questo modo:

1. Da Outlook, premere Alt+F11 per aprire Micorsoft VBA
   
   
2. Inserire uno UserForm e chiamarlo Form_QFM


3. Inserire un controllo casella di testo e chiamarlo tb_FolderName


4. Inserire un controllo casella di riepilogo e chiamarlo lb_Folder


5. Inserire questo codice nell' UserForm Form_QFM
   

   
   Dim FoldersNames() As Outlook.MAPIFolder
   Dim iNumfolders As Long
   
   Private Sub tb_FolderName_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
       If KeyCode = vbKeyEscape Then hide
   End Sub
   
   Private Sub UserForm_Activate()
     tb_FolderName.SetFocus
   End Sub
   
   Private Sub lb_Folder_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
     If KeyCode = vbKeyReturn Then
       ActiveMoveToFolder
     End If
   End Sub
   
   Private Sub lb_Folder_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
     ActiveMoveToFolder
   End Sub
   
   Private Sub tb_FolderName_Change()
     Dim sSaveName As String
   
     Do
       iNumfolders = 0
       ReDim FoldersNames(iNumfolders)
       Set FoldersNames(iNumfolders) = Nothing
       lb_Folder.Clear
     
       sSaveName = tb_FolderName.Text
       If Len(tb_FolderName.Text) > 0 Then FindFolderByName (tb_FolderName.Text)
       If sSaveName = tb_FolderName.Text Then
           Exit Do
       End If
     Loop
       
   End Sub
   
   Sub ActiveMoveToFolder()
     If Not IsNull(lb_Folder.Value) Then
       MoveToFolder FoldersNames(lb_Folder.ListIndex)
     End If
     Form_QFM.hide
   End Sub
   
   Sub FindFolderByName(Name As String)
     Dim i As Long
              
     FindInFolders Application.Session.Folders, Name
        
     If Not FoldersNames(0) Is Nothing Then
       DoEvents
       For i = 0 To UBound(FoldersNames)
         lb_Folder.AddItem FoldersNames(i).Name & vbTab & vbTab & vbTab & vbTab & FoldersNames(i).FolderPath, i
       Next
     End If
   
   End Sub
   
   Function FindInFolders(TheFolders As Outlook.Folders, Name As String)
     Dim SubFolder As Outlook.MAPIFolder
     Dim i As Long
      
     On Error Resume Next
      
     Set FindInFolders = Nothing
      
     DoEvents
     For Each SubFolder In TheFolders
       
       If InStr(LCase(SubFolder.Name), LCase(Name)) > 0 And _
           SubFolder.DefaultItemType = olMailItem And _
           SubFolder.Parent.Class = olFolder Then
         ReDim Preserve FoldersNames(iNumfolders)
         Set FoldersNames(iNumfolders) = SubFolder
         iNumfolders = iNumfolders + 1
         FindInFolders SubFolder.Folders, Name
       Else
         FindInFolders SubFolder.Folders, Name
       End If
     Next
   End Function
   
   Sub MoveToFolder(olDestFolder As Outlook.MAPIFolder)
   
    Dim olApp As New Outlook.Application
    Dim olNameSpace As Outlook.NameSpace
    Dim olCurrExplorer As Outlook.Explorer
    Dim olCurrSelection As Outlook.Selection
   
    Dim olCurrMailItem As MailItem
    Dim m As Integer
   
    Set olNameSpace = olApp.GetNamespace("MAPI")
    Set olCurrExplorer = olApp.ActiveExplorer
    Set olCurrSelection = olCurrExplorer.Selection
    
    For m = 1 To olCurrSelection.Count
       Set olCurrMailItem = olCurrSelection.Item(m)
       olCurrMailItem.Move olDestFolder
    Next m
   
   End Sub
   
   



6. Inserire un nuovo modulo e chiamarlo QFM


7. Inserire questo codice nel modulo  QFM
   

   
   Sub QuickMove()
       With Form_QFM
       .Top = CInt(((Application.ActiveWindow.Height / 2) + Application.ActiveWindow.Top) - (.Height / 2))
       .Left = CInt(((Application.ActiveWindow.Width / 2) + Application.ActiveWindow.Left) - (.Width / 2))
       .Show
       End With
   End Sub
   
   

Ora è possibile richiamare la macro QuickMove che permette, tramite l'apertura della finestra appena creata, di cercare un nome di cartella. Lo script cerca tra tutte le cartelle presenti quelle che contengono la stringa di caratteri inserita, e visualizza la lista nella casella di riepilogo. Con il doppio click sopra una delle voci trovate oppure premendo il tasto enter, il messaggio o i messaggi di posta selezionati saranno spostanti all'interno della cartella selezionata.

Riferimenti:
Move Messages to Folders with Outlook VBA  http://blog.saieva.com/ 
How to search Outlook for a folder name  http://thetechieguy.com/