Shared Mailbox Management

Question

I need a macro that will move messages received into a shared mailbox to a subfolder of that mailbox, depending on the sender's email address, basically a normal outlook rule.

I've been looking at some articles on http://www.slipstick.com/ which has got me part way there but there isn't an exact solution for what I want to do and I'm not proficient enough with VBA in Outlook yet to work it out.

So far I've got this code on ThisOutlookSession to watch the mailbox:

Dim i As Long
Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
  Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
End Sub

And this function in a module to obtain the path of the watched mailbox folder:

' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function

GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

megatron77 megatron77 · Accepted Answer · 2016-05-25T14:29:58

This works, I used a case to move the item if it came from a specific email address:

Dim i As Long
Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
  Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing

    For Each Item In olInboxItems

End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    Dim objDestFolder As Outlook.MAPIFolder
    Dim destFolder As String
    Dim sendersAddress As String

    If Item.Class = olMail Then

        sendersAddress = Item.SenderEmailAddress

        Select Case sendersAddress
            Case "no-reply@omniture.com"
                destFolder = ">Digital Analytics\Inbox\Reports"
            Case "no-reply@edigitalresearch.com"
                destFolder = ">Digital Analytics\Inbox\Reports"
        End Select

Set objDestFolder = GetFolderPath(destFolder)
    Item.Move objDestFolder
    End If

End Sub

Shared Mailbox Management

1 Answers