Visual Basic Programming Code Examples

Visual Basic > Internet Web Mail Stuff Code Examples

Automatically move mail in Outlook 2000



Automatically move mail in Outlook 2000

The following class module is designed to demonstrate how to automatically move new Outlook mail around from folder to folder. A demonstration routine can be found at the bottom of this post.

'If running this project outside of Outlook, please add a reference to
'the Microsoft Outlook 9.0 Office Library

Option Explicit
Option Compare Text

Private WithEvents oOutlookApp As Outlook.Application
Private oNameSpace As Outlook.NameSpace, oInBox As Outlook.MAPIFolder, oMoveToFolder As Outlook.MAPIFolder

Private zsMoveToFolder As String, zsMoveMailSentTo As String, zbMarkAsRead As Boolean
Private Const csNameSeperator As String = ";"


'Purpose   :    Moves mail items to a specified outlook mailbox
'Inputs    :    [bCheckMailBox]                 If True checks all the mail in the inbox and
'                                               moves those sent to the specified name
'Outputs   :    N/A
'Notes     :
'Revisions :

Private Sub MoveNewMail(Optional bCheckMailBox As Boolean)
    Dim oMailItem As Outlook.MailItem
    Dim bMoveMail As Boolean, lPos As Long, lLenMoveMailSentTo As Long
    Dim lUnReadCount As Long, lCheckedMailCount As Long
    Dim lPosOld As Long, sThisName As String
    
    On Error GoTo ErrFailed
    lLenMoveMailSentTo = Len(zsMoveMailSentTo)
    lUnReadCount = oInBox.UnReadItemCount
    
    If lUnReadCount > 0 Or bCheckMailBox = True Then
        'Loop over all mail in mail box
        For Each oMailItem In oInBox.Items
            If oMailItem.UnRead Or bCheckMailBox Then
                lPosOld = 0
                lCheckedMailCount = lCheckedMailCount + 1
                bMoveMail = False                

                If lLenMoveMailSentTo Then
                    'Only move mail items sent to a specified name
                    lPos = InStr(lPosOld + 1, zsMoveMailSentTo, csNameSeperator)
                    Do While (lPos > 0 And (bMoveMail = False And lPos > 0))
                        'Check sent to/cc names
                        sThisName = Mid$(zsMoveMailSentTo, lPosOld + 1, lPos - (lPosOld + 1))
                        If InStr(1, oMailItem.CC, sThisName) Then
                            bMoveMail = True
                        ElseIf InStr(1, oMailItem.To, sThisName) Then
                            bMoveMail = True
                        Else
                            lPosOld = lPos
                            lPos = InStr(lPosOld + 1, zsMoveMailSentTo, csNameSeperator)
                        End If
                    Loop
                Else
                    'Move all new mail to specified folder
                    bMoveMail = True
                End If
                
                If bMoveMail Then
                    'Move mail item
                    If oMailItem.UnRead Then
                        oMailItem.UnRead = Not zbMarkAsRead
                    End If
                    oMailItem.Move oMoveToFolder
                End If
                
                If lCheckedMailCount = lUnReadCount And bCheckMailBox = False Then
                    'Checked all new unread mail
                    Exit For
                End If
            End If
        Next
    End If
    
    Exit Sub

ErrFailed:
    MsgBox "Failed to move mail item..." & vbNewLine & _
    Err.Description, vbCritical
End Sub

'Purpose   :    The path to the folder to move the mail new items to
'Inputs    :    Value                   The folder name. eg. "Personal Folders\Junk Mail\"
'Outputs   :    N/A
'Notes     :
'Revisions :

Property Get MoveToFolder() As String
    MoveToFolder = zsMoveToFolder
End Property


Property Let MoveToFolder(Value As String)
    Dim lPos As Long, sThisFolder As String, lPosOldPos As Long
    
    On Error GoTo ErrFailed
    'Standardise folder variable
    zsMoveToFolder = Value
    If Right$(zsMoveToFolder, 1) <> "\" Then
        zsMoveToFolder = zsMoveToFolder & "\"
    End If
    If Left$(zsMoveToFolder, 1) <> "\" Then
        zsMoveToFolder = "\" & zsMoveToFolder
    End If
    
    lPosOldPos = 2
    Set oMoveToFolder = Nothing
    
    Do
        lPos = InStr(lPosOldPos, zsMoveToFolder, "\")
        If lPos Then
            sThisFolder = Mid$(zsMoveToFolder, lPosOldPos, lPos - lPosOldPos)
            If oMoveToFolder Is Nothing Then
                'Get main folder
                Set oMoveToFolder = oNameSpace.Folders(sThisFolder)
            Else
                'Get sub folder
                Set oMoveToFolder = oMoveToFolder.Folders(sThisFolder)
            End If
        Else
            Exit Do
        End If
        lPosOldPos = lPos + 1
    Loop While lPos
    Exit Property

ErrFailed:
    MsgBox "Failed to locate folder " & Value & vbNewLine & _
    Err.Description
    zsMoveToFolder = ""
End Property

'If set will only move any new mail items sent to the specified name
Property Get MoveMailSentTo() As String
    MoveMailSentTo = zsMoveMailSentTo
End Property

'Deliminated list of names
Property Let MoveMailSentTo(Value As String)
    zsMoveMailSentTo = Value
    If Right$(zsMoveMailSentTo, 1) <> csNameSeperator Then
        zsMoveMailSentTo = zsMoveMailSentTo & csNameSeperator
    End If
End Property

'If True marks the new mail as being read before moving it.
Property Let MarkAsRead(Value As Boolean)
    zbMarkAsRead = Value
End Property

Property Get MarkAsRead() As Boolean
    MarkAsRead = zbMarkAsRead
End Property


Private Sub Class_Initialize()
    Set oOutlookApp = New Outlook.Application
    Set oNameSpace = oOutlookApp.GetNamespace("MAPI")
    Set oInBox = oNameSpace.GetDefaultFolder(olFolderInbox)
End Sub

Private Sub Class_Terminate()
    Set oMoveToFolder = Nothing
    Set oInBox = Nothing
    Set oNameSpace = Nothing
    Set oOutlookApp = Nothing
End Sub

'Manual method of checking the inbox.
'Useful if when creating the class there are
'already new mail items in the inbox
Sub Refresh(Optional bCheckMailBox As Boolean = False)
    If Len(zsMoveToFolder) > 0 And Len(zsMoveMailSentTo) > 0 Then
        MoveNewMail bCheckMailBox
    End If
End Sub

Private Sub oOutlookApp_NewMail()
    'Event fired when new mail is received
    If Len(zsMoveToFolder) > 0 And Len(zsMoveMailSentTo) > 0 Then
        MoveNewMail
    End If
End Sub

PLACE FOLLOWING CODE IN A STANDARD MODULE

Private oMoveAdminMail As clsMoveMail

'This routine moves mail sent to "admin" to a
'folder called "\Personal Folders\admin\"
Sub MoveMailDemo()
    Set oMoveAdminMail= New clsMoveMail
    oMoveAdminMail.MoveMailSentTo = "admin"
    oMoveAdminMail.MoveToFolder = "\Personal Folders\admin\"
    oMoveAdminMail.MarkAsRead = True
    oMoveAdminMail.Refresh                 'Force class to check any new mail
End Sub