Anti spam en macro outlook vba (ma version)


Commenter

Contenu du snippet

Bonjour,

J'ai repris la source déposé par defrance (http://www.vbfrance.com/code.aspx?ID=19925) avec mes petites modifs sur son code. Le but est toujours de virer un maximum de courrier SPAM en gardant les Emails qui me sont réelement destinés .

Dans le principe je regarde quant un Email arrive dans la boite de réception
Je regarde quelques points qui sont bien ententendu des critères qui me sont propres et pas forcément ceux de tous le monde.

Un Email sans Sujet -> poubelles
Un email avec des fichiers .vbs ou .pif pour mon cas c'est un virus

Suivant l'adresse du destinataire il y a plusieurs solutions : Certain de mes
adresses sont clean ( jamais de spam) donc on les laisse tranquiles les autres ben A voir dans le code.

Pour ce qui concerne les mots clés ou adresse indésirable je laisse ceci au règles de l'assistant de gestion de message de outllok . Ces régles seront appliqués au Email restant dans la la boite de réception. Ce qui me permet de virer les Elargisseur de penis ( Merci le mien me suffit ) ainsi que le viagra en vente libre la aussi je me suffit à moi même.



Source / Exemple :

Option Explicit

Private WithEvents olInboxItems As Items
Private WithEvents olSentMailItems As Items
'====================================================================================================================================================
' Declaration des variables
'====================================================================================================================================================
Dim olInboxFolders As Folders
Dim olSentMailFolders As Folders
Dim olDeletedFolder As MAPIFolder
Dim olInbox As MAPIFolder
Dim lItem As Object

'
' Initialisation au démarrage d'outlook
'
Private Sub Application_Startup()
    Dim objNS As NameSpace
    Dim destFolder As Object
    

    Set objNS = Application.GetNamespace("MAPI")
    
    Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
    
    Set olInboxFolders = objNS.GetDefaultFolder(olFolderInbox).Folders
       
    Set olSentMailItems = objNS.GetDefaultFolder(olFolderSentMail).Items
    
    Set olSentMailFolders = objNS.GetDefaultFolder(olFolderSentMail).Folders
    
    Set olDeletedFolder = objNS.GetDefaultFolder(olFolderDeletedItems)
    
    Set olInbox = objNS.GetDefaultFolder(olFolderInbox)
    
    
    Set objNS = Nothing
    
    'Permet de créer un répertoire tempo pour Y classer des Emails douteux
    ' Email à analyser
    On Error Resume Next
    Set destFolder = olInboxFolders.Add(">>>Douteux", olFolderInbox)
End Sub

Private Sub Application_Quit()
    ' disassociate global objects
    Set olInboxItems = Nothing
    Set olInboxFolders = Nothing

    Set olSentMailItems = Nothing
    Set olSentMailFolders = Nothing
    Set olInbox = Nothing
End Sub

'-----------------------------------------------------------------------------
' A l'arrivée d'un nouvel Email
' Test un certain nombre de trucs
' Si l'email est douteux alors il sera transféré dans le dossier
'  >> douteux de plus Un commentaire sera rajouté au début du Sujet ce qui permet de
'  Visualiser rapidement la raison de sa mise à l'écart
' Depuis Que j'utilse ces techniques je vire 95% des Emails Merdiques
' Avec assez peu d'erreur C'est pour cette raison que les Emails sont mis dans douteux ce qui laisse une chance
' De rattraper L'email Ecarté par erreur :))

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
    Dim Ind As Integer
    Dim AVirer As Boolean
    Dim Strcmp As String
    Dim Ind_B As Integer
    Dim RechercheSTR As String
    Dim DetectionSpam As String
    Dim DejaVue As Boolean
  
    ' si un nouveau message arrive
    On Error Resume Next
   

    If Item.Class = olMail Then
    
                    ' Si pas de sujet alors Poubelle
                    ' Méthode Super efficace dans mon cas
                    ' Le minimum si on t'envoi un Mil c'est de te dire pourquoi
                    ' Si c'est pas le cas Pas la peine de prendre le temps de le lire
                    If Len(Item.Subject) = 0 Then
                               Item.Move olDeletedFolder
                    Else
                        
                        '''''''''''''''''''''''''''''''''''''''''''''''
                        ' Regarde le sujet
                        '''''''''''''''''''''''''''''''''''''''''''''''
                        ' @ dans le sujet comme vi@gra ou v@alium
                        ' Méthode pas vraiement efficace
                        ' A améliorer
                        If InStr(UCase(Item.Subject), "@") > 0 Then
                                Item.Subject = "[@ Dans Sujet] " + Item.Subject
                                Item.Move olInboxFolders(">>>Douteux")
                                GoTo FinAnalyse
                        End If


                        '''''''''''''''''''''''''''''''''''''''''''''''
                        ' Regarde l'Expéditeur
                        '''''''''''''''''''''''''''''''''''''''''''''''
                        'Test sur un nom d'Expéditeur
                        ' Méthode peu efficace et doublon avec Expéditeurs indésirable de outlook
                        If Item.SenderName = "@" Then
                               Item.Subject = "[SenderName=@] " + Item.Subject
                               Item.Move olInboxFolders(">>>Douteux")
                               GoTo FinAnalyse
                        End If
                            
  
                        '''''''''''''''''''''''''''''''''''''''''''''''
                        ' Test les destinataires
                        '''''''''''''''''''''''''''''''''''''''''''''''
                        ' Si pas de destinataire
                        ' Méthode 100% Efficace dans mon cas
                        If Item.Recipients.Count = 0 Then
                            Item.Subject = "[Pas de destinataire] " + Item.Subject
                            Item.Move olInboxFolders(">>>Douteux")
                            GoTo FinAnalyse
                        End If
                        
                        '''''''''''''''''''''''''''''''''''''''''''''''
                        ' Regarde les adresses du/des destinataires
                        '''''''''''''''''''''''''''''''''''''''''''''''
                        AVirer = True
                        DejaVue = False
                
                        ' Si dans tous les destinataires une de mes adresses n'apparait pas alors
                        ' Avirer =true
                        ' Méthode très efficace dans mon cas
                        RaisonSpam = "AucuneAdressePrésente"

                        ' Boucle sur nombre de destinataires
                        For Ind = 1 To Item.Recipients.Count


                                'Debug.Print UCase(Item.Recipients.Item(ind).Address)


                                Select Case UCase(Item.Recipients.Item(Ind).Address)
                                        ' Adresse poubelle
                                        Case "POUBELLE@SPAM.FR"
                                           AVirer = False
                                                ' plus de 2 destinataires
                                                If Item.Recipients.Count > 2 Then
                                                 Item.Subject = "[Sur Free + 2 destinataires] " + Item.Subject
                                                 Item.Move olInboxFolders(">>>Douteux")
                                                 GoTo FinAnalyse
                                                End If
                                                
                                        ' Adresses newsgroup
                                        ' A ne pas virer
                                        Case "NEWSGROUP@YAHOOGROUPES.FR", "NEWSGROUPE@YAHOOGROUPES.FR"
                                            AVirer = False
                                            DejaVue = True ' Evite les tests sur le contenu
                             
                                        ' Adresse Perso Clean
                                        ' Adresse donnée seulement aux amis
                                        ' 100%  non SPAM
                                        Case "PERSO@PERSO.FR"
                                           AVirer = False
                                           DejaVue = True ' Evite les tests sur le contenu
                                           
                                        ' Adresse boulot Clean
                                        ' Adresse donnée seulement au compte goutte
                                        ' 100%  non SPAM
                                        Case "BOULOT@BOULOT.COM"
                                           AVirer = False
                                           DejaVue = True ' Evite les tests sur le contenu

                                        ' Adresse boulot
                                        Case "INFO@BOULOT.COM", "CONTACT@BOULOT.COM"
                                           ' Regarde les deux première lettres
                                           ' si pour toutes les adresses c'est pareil alors
                                           ' ca sent le SPAM
                                           ' Marche Moyen
                                           If Item.Recipients.Count > 2 Then
                                                Strcmp = UCase(Mid$(Item.Recipients.Item(1).Address, 1, 2))
                                                For Ind_B = 2 To Item.Recipients.Count
                                                         If UCase(Mid$(Item.Recipients.Item(Ind).Address, 1, 2)) <> Strcmp Then
                                                            AVirer = False
                                                            Exit For
                                                         End If
                                                Next Ind_B
                                                RaisonSpam = "AdresseBoulotAvecListeAdresse"
                                           Else
                                              AVirer = False
                                           End If
                                           
                                         ' Adresse véreuse Particulière
                                         ' par exemple utilisé pour laisser ses coordonées sur un site
                                         ' Ce qui arrive ici = 99.9 % SPAM
                                          Case "ULTRA_POUBELLE@SPAM.FR"
                                               AVirer = True
                                               Item.Subject = "[Adresse POUBELLE] " + Item.Subject
                                               Item.Move olDeletedFolder
                                               GoTo FinAnalyse
                                           Exit For
                                                                                
                                        Case Else
                                            'MsgBox " Un Mail pour " & Item.Recipients.Item(Ind).Address
                                 
                                 End Select
                                 
                         
                         Next Ind


                         ' Si Avirer alors Action !!!!!!!!!!!!!!
                         If AVirer Then
                            Item.Subject = "[" + RaisonSpam + "] " + Item.Subject
                            Item.Move olInboxFolders(">>>Douteux")
                            GoTo FinAnalyse
                         End If
                         

                        
                        ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                        ' regarde les attachment
                        ' et vire les fichiers .pif et .VBS Source de virus dans mon cas
                        ' + dans mon cas  les fichiers DELETE0.TXT Email scanné et detection virus
                        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                        For Ind = 1 To Item.Attachments.Count
                            If InStr(UCase(Item.Attachments.Item(Ind).DisplayName), ".PIF") > 0 Or InStr(UCase(Item.Attachments.Item(Ind).FileName), ".PIF") > 0 Then
                                Item.Move olDeletedFolder
                                GoTo FinAnalyse
                            End If
                            'Fichier scanné par Antivirus
                            If InStr(UCase(Item.Attachments.Item(Ind).DisplayName), "DELETED0.TXT") > 0 Or InStr(UCase(Item.Attachments.Item(Ind).FileName), "DELETED0.TXT") > 0 Then
                                Item.Move olDeletedFolder
                                GoTo FinAnalyse
                            End If
                            If InStr(UCase(Item.Attachments.Item(Ind).DisplayName), ".VBS") > 0 Or InStr(UCase(Item.Attachments.Item(Ind).FileName), ".VBS") > 0 Then
                                Item.Move olDeletedFolder
                                GoTo FinAnalyse
                            End If
                        Next Ind

                        
                        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                        ' Regarde le contenu HTML
                        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                        ' Beaucoup de pub arrive sous le format HTML
                        ' Souvent Il y a un lien vers un site
                        ' détecte la présence de lien
                        ' Méthode qui marche pas mal mais pas fiable à 100%
                        '
                        ' "src=" + Chr(34) + "http://"
                        If Len(Item.HTMLBody) > 0 And DejaVue = False Then
                        RechercheSTR = "src=" + Chr(34) + "http://"
                        RechercheSTR = UCase(RechercheSTR)
                                If InStr(UCase(Item.HTMLBody), RechercheSTR) > 0 Then
                                        Item.Subject = "[PresenceLienHTML] " + Item.Subject
                                        Item.Move olInboxFolders(">>>Douteux")
                                        GoTo FinAnalyse
                                End If
                        End If
                    End If
    
   End If

FinAnalyse:

End Sub


' Fonctions pouvant être rajoutées dans la barre des boutons outlook
' Soit pour vaoir certainne info sur un Mail vant de l'ouvrir
' soit pour tester des trucs sur les Emails avant de rajouter ces méthodes dans
' L'analyse
'Info sur un Email
'
Public Sub Info()
    Dim lItem As Object
    Dim Ind As Integer
    Dim msg_txt As String
    
    For Each lItem In Application.ActiveExplorer.Selection
        On Error Resume Next
            ' si c'est un mail
    If IsObject(lItem) Then
        If lItem.Class = olMail Then
         msg_txt = lItem.SenderName & " Email : " & lItem.SentOnBehalfOfName
         
         For Ind = 1 To lItem.Recipients.Count
              msg_txt = msg_txt + Chr(10) + "Recipient  :" _
              & lItem.Recipients.Item(Ind).Address
         Next Ind
       End If
   End If
   Next

    MsgBox msg_txt
End Sub
'Info sur un Email
Public Sub Info2()
    Dim lItem As Object

    
    For Each lItem In Application.ActiveExplorer.Selection
        On Error Resume Next
            ' si c'est un mail
        If IsObject(lItem) Then
            If lItem.Class = olMail Then
            'Contenu HTML
                'MsgBox lItem.HTMLBody
                ' nom du destinataire
                MsgBox "Nom du destinataire    :" & lItem.ReceivedByName _
            & Chr(10) & "Confirmation relecture :" & lItem.ReadReceiptRequested _
            & Chr(10) & "Destinataires de la réponse    :" & lItem.ReplyRecipientNames _
            & Chr(10) & "Destinataires                  :" & lItem.To _
            & Chr(10) & "Destinataires     CC           :" & lItem.CC _
            & Chr(10) & "Destinataires     BCC          :" & lItem.BCC
            End If
        End If
        
    Next
End Sub
' Test pour les liens HTML
Public Sub Test_Un_truc()
    Dim lItem As Object
    Dim RechercheSTRA As String
    Dim RechercheSTRB As String
    
    For Each lItem In Application.ActiveExplorer.Selection
        On Error Resume Next
            ' si c'est un mail
            If IsObject(lItem) Then
                If lItem.Class = olMail Then
                                 ' Regarde le contenu
                                ' "src=" + Chr(34) + "http://"
                                If Len(lItem.HTMLBody) > 0 Then
                                    RechercheSTRA = "src=" + Chr(34) + "http://"
                                    
                                    RechercheSTRA = UCase(RechercheSTRA)
                                   
                                    If InStr(UCase(lItem.HTMLBody), RechercheSTRA) > 0 Then
                                        MsgBox "bingo!!!" & InStr(UCase(lItem.subjet), RechercheSTRA)
                                    End If
                                End If
                 End If
          End If
        
    Next

End Sub

' Caratères  bizarre dans Email comme par exemple Mail asiatique ou petit malin avec le Ì , ì pour vìagra
' Méthode en cours d'expérimentation
Public Sub Test_Un_autre_truc()
    Dim lItem As Object
    Dim Ind As Integer
    Dim RechercheSTRA As String
    Dim RechercheSTRB As String
    
    For Each lItem In Application.ActiveExplorer.Selection
        On Error Resume Next
            ' si c'est un mail
            If IsObject(lItem) Then
                If lItem.Class = olMail Then
                                    For Ind = 127 To 255
                                        Select Case Ind
                                        ' Caractère pouvant être présent dans un Email francais
                                        Case 200, 201, 219, 224, 231, 232, 233, 234, 244, 248, 251 ' Respectivement ÈÉÛàçèéêôøû
                                        
                                        Case Else
                                            If InStr(lItem.Subject, Chr$(Ind)) > 0 Then
                                                MsgBox "bingo Taï !!!-<" & Chr$(Ind) & ">"
                                                Exit For
                                            End If
                                    Next Ind
                 End If
          End If
        
    Next

End Sub

Conclusion :

Les routines rajoutées à la fin du code peuvent être rajouté à la barre des boutons d'outlook pour avoir d'autres infos sur un Mail ou pour tester des petits truc avant de l'intégrer comme détection de SPAM.

Cette méthode marche plutot bien dans mon cas .. A vous de faire votre propre sauce avec vos propres règles.

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cuq)