01)Private WithEvents olInboxItems As Items
02)
03)Private Sub Application_Startup()
04)  Dim objNS As NameSpace
05)  Set objNS = Application.GetNamespace("MAPI")
06)  Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
07)  Set objNS = Nothing
08)End Sub
09)
10)Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
11)  Dim objAttFld As MAPIFolder
12)  Dim objInbox As MAPIFolder
13)  Dim objNS As NameSpace
14)  Dim strAttFldName As String
15)  Dim strProgExt As String
16)  Dim arrExt() As String
17)  Dim objAtt As Attachment
18)  Dim intPos As Integer
19)  Dim I As Integer
20)  Dim strExt As String
21)
22)  ' #### OPÇÕES ####
23)  ' Nome da subpasta que armazenará as mensagens com anexos suspeitos
24)  strAttFldName = "Perigoso"
25)  ' Lista de extensões perigosas
26)  strProgExt = "exe, bat, com, vbs, vbe, pif, scr"
27)
28)  On Error Resume Next
29)  Set objNS = Application.GetNamespace("MAPI")
30)  Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
31)  Set objAttFld = objInbox.Folders(strAttFldName)
32)  If Item.Class = olMail Then
33)    If objAttFld Is Nothing Then
34)      ' Cria a pasta se necessário
35)      Set objAttFld = objInbox.Folders.Add(strAttFldName)
36)   End If
37)    If Not objAttFld Is Nothing Then
38)      ' Armazena a lista de extensões em um Vetor
39)      arrExt = Split(strProgExt, ",")
40)      For Each objAtt In Item.Attachments
41)        intPos = InStrRev(objAtt.FileName, ".")
42)        If intPos > 0 Then
43)          ' Checa a extensão do anexo
44)          strExt = LCase(Mid(objAtt.FileName, intPos + 1))
45)          For I = LBound(arrExt) To UBound(arrExt)
46)            If strExt = Trim(arrExt(I)) Then
47)              Item.Move objAttFld
48)              Exit For
49)            End If
50)          Next
51)        Else
52)          ' Anexos sem extensão também serão movidos
53)          Item.Move objAttFld
54)        End If
55)      Next
56)    End If
57)  End If
58)
59)  On Error GoTo 0
60)  Set objAttFld = Nothing
61)  Set objInbox = Nothing
62)  Set objNS = Nothing
63)  Set objAtt = Nothing
64)End Sub