outlook file script

outlok_file_script.vb

Sub FileItem()
Dim Item As MailItem
Set Item = Outlook.Application.ActiveExplorer.Selection.Item(1)
Item.ShowCategoriesDialog
If Not Item.Categories = "" Then
    Item.UnRead = False
    Set dstFolder = GetFolder("Mailbox - ME\File")
    Item.Move dstFolder
End If
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If
  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function