Soyez le premier à donner votre avis sur cette source.
Snippet vu 9 865 fois - Téléchargée 29 fois
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
13 mars 2007 à 10:05
9 juil. 2004 à 14:16
Comment faire pour ajouter un filtre sur l'e-mail de l'envoyeur?
(En fait, comment récupérer l'adresse e-mail de l'envoyeur?)
3 juin 2004 à 17:18
De publier dans un forum Usenet avec une adresse en clair, ou bien :
De mettre son email en clair sur sa page web, voilà ! (je garanti le résultat !)
Sinon, tu peux aussi laisser ton email partout sur les sites commerciaux en cochant la case "je veux etre spammé car je suis un gros naze"
3 juin 2004 à 14:00
Faut dire que j'utilise pas Outlook, ça doit etre pour ça :p
14 mai 2004 à 09:40
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.