VBA outlook实战#02--自动分类邮件

VBA编程实现邮件自动分类

通过脚本，接收邮件后，自动移动到相应的文件夹。

1. 首先在收信箱下创建三个文件夹：HR、IT和Software。
2. 其次通过GetFolder(strFolderPath As String)方法获取文件夹对象。
3. 然后根据CheckInContact(mailAdress As String)方法获取发信人的部门信息。
4. 最后根据部门信息，移动邮件到相应的文件夹。

Sub AutoMove(Item As Outlook.mailItem)    Dim var As Variant        var = ClassifyMail(Item)        Set Item = NothingEnd SubPublic Function ClassifyMail(Item As Outlook.mailItem)'move mail to related folder    Dim objApp As Outlook.Application    Dim objNS As Outlook.NameSpace    Dim srcFolder As Outlook.Folder    Dim dstFolder As Outlook.Folder    Dim srcFolderPath As String    Dim dstFolderPath As String    Dim i As Integer    On Error GoTo last    Set objApp = Application    Set objNS = objApp.GetNamespace("MAPI")    srcFolderPath = "Outlook\收件箱"    Set srcFolder = GetFolder(srcFolderPath)    Select Case CheckInContact(Item.SenderEmailAddress)        Case 0:            dstFolderPath = "Outlook\收件箱\HR"        Case 1:            dstFolderPath = "Outlook\收件箱\IT"        Case 2:            dstFolderPath = "Outlook\收件箱\Software"        Case Else:            GoTo last    End Select    Set dstFolder = GetFolder(dstFolderPath)    Item.Move dstFolderlast:    Set objApp = Nothing    Set objNS = Nothing    Set srcFolder = Nothing    Set dstFolder = NothingEnd FunctionPublic 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 = NothingEnd FunctionPublic Function CheckInContact(mailAdress As String) As Integer    'Check this adress whether it is in contactfolder.    'Return ID    Dim objApp As Outlook.Application    Dim objNS As Outlook.NameSpace    Dim contactsFolder As Outlook.Folder    Dim contactItem As Outlook.contactItem    Dim departmentID As Integer    On Error GoTo last    departmentID = -3 'Error ID    Set objApp = Application    Set objNS = objApp.GetNamespace("MAPI")    Set contactsFolder = objNS.GetDefaultFolder(olFolderContacts)    For Each contactItem In contactsFolder.Items        If contactItem.Email1Address = mailAdress Then            Select Case contactItem.Department                Case "HR"                    departmentID = 0                Case "IT"                    departmentID = 1                Case "Software"                    departmentID = 2                Case Else                    departmentID = -1            End Select            Exit For        Else            departmentID = -2 'No found ID        End If    Nextlast:    CheckInContact = departmentID    Set objApp = Nothing    Set objNS = Nothing    Set contactsFolder = Nothing    Set contactItem = NothingEnd Function