Archive button in Outlook (like gmail)

So this is the working solution that i finally put together for my self.
i hope it helps you.
This is how the button looks when we are done.

 
// 
Sub to_tempArchive()
Set objFolder = GetFolder("2013 Archive \02 Archive")


Set ArchiveFolder = Application.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderInbox).Parent.Folders("temp_Archive")



For Each Msg In ActiveExplorer.Selection
Msg.UnRead = False
Msg.Move objFolder

Next Msg
End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder
  ' strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"

  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 = 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
Labels: , , , , , , , , , , ,