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 |
Partager