Comment faire pour que la macro s'execute automatique à la recpetion d'un mail?

[remsbdx]

Bonjour à tous,

Comment faire pour que la macro s'execute automatique à la recpetion d'un mail?

Voici le code :

Code :

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
Private Sub Application_NewMail()
    Dim MonApply As Outlook.Application
    Dim MonMail As Outlook.MailItem
    Dim MonNSpace As Outlook.NameSpace
    Dim FldDossier As Outlook.Folder
    Dim strInfos As String
    Dim myItem As Object
 
    'Instance des Objets
    Set MonApply = Outlook.Application    'Application Outlook
    Set MonNSpace = MonApply.GetNamespace("MAPI")    'Banque MAPI
    Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox) 'Dossier boîte de réception
    Set DestFolder = FldDossier.Folders("Temp")
    'Initialisation de la chaîne de caractères
    strInfos = ""
    'Boucle afin de parcourir l'ensemble des E-mails présents dans le dossier Boîte de réception
    For i = 1 To FldDossier.Items.Count
        'instancie le mail suivant la valeur de la boucle
        Set MonMail = FldDossier.Items(i)
        'Test sur le sujet si égale à Invitation
        'If MonMail.Subject = "nagios" Then
        If MonMail.Subject = "test" Then
            MonMail.Move DestFolder
        'Récupère les diverses informations du Mail ayant pour sujet Invitation
            With MonMail
                strInfos = "Expéditeur : " & .SenderEmailAddress
                strInfos = strInfos & vbCr & "Destinataire(s) : " & .To
                strInfos = strInfos & vbCr & "Date de réception : " & .ReceivedTime
            End With
            'Affichage du résultat
            MsgBox strInfos
        End If
    Next i
 
    'Vide des instances
    Set MonApply = Nothing
    Set MonNSpace = Nothing
    Set FldDossier = Nothing
    Set MonMail = Nothing
 
    'Application.TimeZones
 
End Sub

[Philippe JOCHMANS]

Bonjour

Je t'invite à lire ce tuto : Initiation au VBA d'Outlook


Tu y trouveras une liste des évènements sur OutLook.

Philippe

[remsbdx]

J'ai lu le tuto, jai fait des tests mais cela n'est pas concluant

[Philippe JOCHMANS]

Envoyé par remsbdx

J'ai lu le tuto, jai fait des tests mais cela n'est pas concluant

Cela va tout dire et rien à la fois, car on ne sait pas ce que tu as testé

Et le non concluant veut dire quoi ? Message d'erreur ? Ce n'est pas le résultat attendu ?

Je ne comprends pas comment vous pouvez avoir de l'aide sans donner des détails

Philippe

[remsbdx]

Excusez moi de ne pas avoir donné de détail, mais quand je dis que ce n'est pas concluant, c'est qu'il n'y a rien qui se passe, je fais un test d'envoi de mail sur ma boite

Je suis obligé d'éxecuter la macro manuellement.

[carden752]

Bonjour,

Essayes de mettre un msgbox au début de la procédure pour voir déjà si Outlook déclenche bien cet évènement.
Si tel est le cas, il ne te reste plus qu'à explorer ton objet en pas à pas pour t'assurer que le test sur le sujet est bien le bon et que ton mail est bien reçu dans la boite de réception directement.

Attention DestFolder n'est pas déclaré apparemment.

[remsbdx]

C'est bon la macro s'éxecute automatiquement a la reception d'un mail.

Le test que je fais est ler suivant : à la reception d'un mail avec un mot dans le corp du message, la macro se déclenche.

Maintenant ma deuxieme partie c'est récuper ce mail et de créer un ticket dans notre système de ticketing via cette méthode :

Code :

1
2
3
4
5
 Dim c As ADODB.Connection  
Set c = New 
ADODB.Connection 
c.Open "DSN=fusion
Dim r As ADODB.Recordset

Comment puis-je faire ensuite pendant le test:

Par exemple, je teste la condition si dans le corps du message, il y a un mot type (exemple : test), cela crée un ticket.

J'ai les numéro de domaine

[remsbdx]

Bonjour,

J'ai à nouveau un soucis avec la macro, quand j'essaye de l'executer ca met un message d'erreur.

Apparement cela serait du à cette ligne :

Code :

Set MonMail = MonDossier.Items(i)

Code :

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
 
Public Sub NewMail()
'---------------------------------------------------------------------------------------
' Procédure : Application_NewMail
' Auteur    : Remy SALLE
' Détail    : Permet de déplacer le nouveau message si celui-ci est envoyé par un expéditeur précis et de créer un incident automatiquement dans Fusion
'---------------------------------------------------------------------------------------
'
    'Déclarations
    Dim MonApp As Outlook.Application
    Dim MonNameSpace As Outlook.NameSpace
    Dim MonDossier As Outlook.Folder
    Dim MonMail As Outlook.MailItem
    Dim i As Integer
 
    Dim domain As String
    domain = 0
    Dim c As ADODB.Connection
    Set c = New ADODB.Connection
    c.Open "DSN=fusion"
    Dim r As ADODB.Recordset
 
    Dim objcategory As String
    Dim objreceivedate As String
    Dim objsavedate As String
    objsavedate = VBA.Format(Now(), "YYYY-MM-DD HH:MM:SS")
    Dim objsubject As String
    Dim objheader As String
    Dim objreceipt As String
    Dim objsender As String
    Dim objsendermail As String
    Dim objBody As String
 
    Dim get_id_req As String
    Dim dticket_id As String
    Dim update_req As String
 
    'Instance des objets
    Set MonApp = Outlook.Application
    Set MonNameSpace = MonApp.GetNamespace("MAPI")
    Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox) 'Boite de reception
    Set DestFolder = MonDossier.Folders("Temp")
    i = MonDossier.Items.Count
    For i = 1 To MonDossier.Items.Count
        'Test si l'expéditeur correspond dans ce cas on déplace le mail
        'vers le dossier Temp de votre boîte de réception
        Set MonMail = MonDossier.Items(i)
        If MonMail.Subject = "nagios" Then
            MonMail.Move DestFolder
            domain = 60
            sql = "select domain_name, domain_id from domain where domain_name like '%CNSA INTERNE%' order by domain_name "
            Set r = c.Execute(sql)
            objcategory = MonMail.Categories
            For j = 1 To MonMail.Recipients.Count
            objreceipt = objreceipt & MonMail.Recipients.Item(j).Name
            Next j
            objsubject = MonMail.Subject
            objheader = Returnheadermail(MonMail)
            objsendermail = ReturnSenderMail(MonMail)
            objreceivedate = VBA.Format(MonMail.ReceivedTime, "YYYY-MM-DD HH:MM:SS")
                If MonMail.Body <> olFormatHTML Then
                    objBody = MonMail.Body
                End If
            sq = "INSERT INTO `dticket` VALUES ('','" & objsubject & "','" & objcategory & "','" & objheader & "','" & MonMail.Importance & "','" & objsender & "','" & objsendermail & "','','" & objreceipt & "','" & objreceivedate & "'',''" & objsavedate & "','','','" & objBody & "','O','','','','','',''," & domain & ",'');"
            Set r = c.Execute(sq)
            get_id_req = "select last_insert_id()"
            Set r = c.Execute(get_id_req)
            update_req = "update dticket set dticket_subject='" & objsubject & " (Incident #" & dticket_id & ")' where dticket_id=" & dticket_id
            Set r = c.Execute(update_req)
        End If
        Next i
End Sub

[lepotier]

Essaie

Code :

1
2
 
Set MonMail = MonDossier.UserProperties.Items(i)