[exchange]Limitation des règles à 32ko

Public WithEvents myOlItems As Outlook.Items

Public Sub Application_Startup()
    Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal Item As Object)
    On Error Resume Next
    
    '---------------------------------
    ' CHANGE THE FOLLOWING SETTINGS
    '---------------------------------
    Excel_Workbook = "rules.xls"
    
    Root_Folder_Name = "D:\Mail\"
    Log_File_Name = "rules.log"

    '---------------------------------
    ' DO NOT CHANGE THE FOLLOWING CODE
    '---------------------------------
    Excel_Workbook = Root_Folder_Name & Excel_Workbook

    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myOrigFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    
    Set myXlApp = CreateObject("Excel.Application")
    Set myWorkBook = myXlApp.Workbooks.Open(Excel_Workbook)
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    If TypeName(Item) = "MailItem" Then
        intRow = 2
        Do Until myXlApp.Cells(intRow, 1).Value = "" And myXlApp.Cells(intRow, 2).Value = ""
        ' Parsing règle
            If Not myXlApp.Cells(intRow, 1).Value = "" Then
            ' Address not null
                If StrConv(Item.SenderEmailAddress, vbLowerCase) = StrConv(myXlApp.Cells(intRow, 1).Value, vbLowerCase) Then
                    If Not myXlApp.Cells(intRow, 3).Value = "" Then
                    ' Archive not null
                        If Not moveMail(myDestArbo, myXlApp, intRow, myNameSpace, Item) Then MsgBox "Mail not moved to folder (line " & intRow & " in Rules File)", vbCritical, "Castor Sorting Script"
                        Exit Do
                    End If
                End If
                If InStr(1, StrConv(Item.SenderName, vbLowerCase), StrConv(myXlApp.Cells(intRow, 1).Value, vbLowerCase), vbTextCompare) Then
                    If Not myXlApp.Cells(intRow, 3).Value = "" Then
                    ' Archive not null
                        If Not moveMail(myDestArbo, myXlApp, intRow, myNameSpace, Item) Then MsgBox "Mail not moved to folder (line " & intRow & " in Rules File)", vbCritical, "Castor Sorting Script"
                        Exit Do
                    End If
                End If
            End If
            If Not myXlApp.Cells(intRow, 2).Value = "" Then
            'Object not null
                If InStr(1, Item.Subject, myXlApp.Cells(intRow, 2).Value, vbTextCompare) Then
                    If Not myXlApp.Cells(intRow, 3).Value = "" Then
                    ' Archive not null
                        If Not moveMail(myDestArbo, myXlApp, intRow, myNameSpace, Item) Then MsgBox "Mail not moved to folder (line " & intRow & " in Rules File)", vbCritical, "Castor Sorting Script"
                        Exit Do
                    End If
                End If
            End If
            intRow = intRow + 1
        Loop
    End If
    myXlApp.Quit
End Sub

Function moveMail(myArbo, myXlFile, myIntRow, nameSpace, myItem) As Boolean
    On Error Resume Next
    myBool = True
    
    Set myArbo = nameSpace.Folders(myXlFile.Cells(myIntRow, 3).Value)
    mySubArbo = Split(myXlFile.Cells(myIntRow, 4).Value, "\", -1, vbTextCompare)
    For Each Folder In mySubArbo
        Set myArbo = myArbo.Folders(Folder)
        
        If Err.Number Then
            MsgBox "Error : Folder " & Folder & " doesn't exist", vbCritical, "Castor Sorting Script"
            myBool = False
            Exit For
        End If
    Next Folder
    If myBool Then
        myItem.move myArbo
    End If
    moveMail = myBool
End Function