Anti spam en macro outlook vba (ma version)
Soyez le premier à donner votre avis sur cette source.
Snippet vu 8 927 fois - Téléchargée 28 fois
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.
Cette méthode marche plutot bien dans mon cas .. A vous de faire votre propre sauce avec vos propres règles.
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 SubConclusion :
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.
Commentaires
- Messages postés
- 1222
- Date d'inscription
- jeudi 23 août 2001
- Statut
- Membre
- Dernière intervention
- 9 septembre 2018
-- Messages postés
- 394
- Date d'inscription
- mercredi 30 janvier 2002
- Statut
- Membre
- Dernière intervention
- 4 novembre 2009
1 -Non sans dec.. car si faut 4? pour le spam + 15? pour un serveur Web + 30?ligne FT+Adsl + 20? de coca ..
Chuis pas Rotshild !
- Messages postés
- 394
- Date d'inscription
- mercredi 30 janvier 2002
- Statut
- Membre
- Dernière intervention
- 4 novembre 2009
1 -Mah bon
il a du économiser pour ces 5? de cigarettes..
- Messages postés
- 1222
- Date d'inscription
- jeudi 23 août 2001
- Statut
- Membre
- Dernière intervention
- 9 septembre 2018
-- Messages postés
- 394
- Date d'inscription
- mercredi 30 janvier 2002
- Statut
- Membre
- Dernière intervention
- 4 novembre 2009
1 -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.