1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
|
'Macro a enregistrer dans ThisOutlookSession
Private Sub Application_NewMail()
SortMail
End Sub
Sub SortMail()
On Error GoTo SortMail_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Logfilepath As String
Dim Recipient As String
Dim Good As MAPIFolder
Dim Bad As MAPIFolder
Dim i As Integer
Set ns = GetNamespace("MAPI")
' Variable du fichier de log, pour l'instant non utilisée
'Le répertoire boîte de réception
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
'Les réservations traitées
Set Good = Inbox.Folders("Good")
'Les mails qui ne sont pas des réservations
Set Bad = Inbox.Folders("Bad")
'Si la macro est lancée à la main
If Inbox.Items.Count = 0 Then
MsgBox "Il n'y a pas de message dans la boîte de réception", vbInformation
Exit Sub
End If
i = 0
'On boucle sur les mails
For Each Item In Inbox.Items
'On récupère l'addresse mail dans Recipient
Subject = Split(Item.Subject, ";")
Recipient = Subject(0)
'On vérifie l'adresse mail
If ValidEmail(Recipient) Then
If TypeName(Item) = "MailItem" Then
'On créer le mail a rediriger
Set myForward = Item.Forward
myForward.Recipients.Add Recipient
myForward.Send
Item.Move Good
End If
Else
Item.Move Bad
End If
Next Item
SortMail_exit:
Set Item = Nothing
Set ns = Nothing
Exit Sub
SortMail_err:
MsgBox "Une erreur est survenue" _
& vbCrLf & "Nom de la macro: SortMail" _
& vbCrLf & "Erreur n°: " & Err.Number _
& vbCrLf & "Description de l'erreur: " & Err.Description _
, vbCritical, "Erreur!"
Resume SortMail_exit
End Sub
Function ValidEmail(ByVal strCheck As String) As Boolean
Dim bCK As Boolean
Dim strDomainType As String
Dim strDomainName As String
Const sInvalidChars As String = "!#$%^&*()=+{}[]|\;:'/?>,< "
Dim i As Integer
bCK = Not InStr(1, strCheck, Chr(34)) > 0 'Check to see if there is a double quote
If Not bCK Then GoTo ExitFunction
bCK = Not InStr(1, strCheck, "..") > 0 'Check to see if there are consecutive dots
If Not bCK Then GoTo ExitFunction
' Check for invalid characters.
If Len(strCheck) > Len(sInvalidChars) Then
For i = 1 To Len(sInvalidChars)
If InStr(strCheck, Mid(sInvalidChars, i, 1)) > 0 Then
bCK = False
GoTo ExitFunction
End If
Next
Else
For i = 1 To Len(strCheck)
If InStr(sInvalidChars, Mid(strCheck, i, 1)) > 0 Then
bCK = False
GoTo ExitFunction
End If
Next
End If
If InStr(1, strCheck, "@") > 1 Then 'Check for an @ symbol
bCK = Len(Left(strCheck, InStr(1, strCheck, "@") - 1)) > 0
Else
bCK = False
End If
If Not bCK Then GoTo ExitFunction
strCheck = Right(strCheck, Len(strCheck) - InStr(1, strCheck, "@"))
bCK = Not InStr(1, strCheck, "@") > 0 'Check to see if there are too many @'s
If Not bCK Then GoTo ExitFunction
strDomainType = Right(strCheck, Len(strCheck) - InStr(1, strCheck, "."))
bCK = Len(strDomainType) > 0 And InStr(1, strCheck, ".") < Len(strCheck)
If Not bCK Then GoTo ExitFunction
strCheck = Left(strCheck, Len(strCheck) - Len(strDomainType) - 1)
Do Until InStr(1, strCheck, ".") <= 1
If Len(strCheck) >= InStr(1, strCheck, ".") Then
strCheck = Left(strCheck, Len(strCheck) - (InStr(1, strCheck, ".") - 1))
Else
bCK = False
GoTo ExitFunction
End If
Loop
If strCheck = "." Or Len(strCheck) = 0 Then bCK = False
ExitFunction:
ValidEmail = bCK
End Function |
Partager