Option Explicit 'J'utilise beaucoup de constante car ces informations peuvent varier. Public Const NOM_FICHIER = "Rapport_" Public Const EXT_FICHIER = ".xls" Public Const REP_FICHIER = "D:\GARNIER\FG\Application\Rapport" Public Const SEP_MSG_A = "WAN" Public Const SEP_MSG_B = " - " Public Const TYP_STR_A = "*blocked*" Public Const TYP_STR_B = "*Access site*" Public Const TYP_STR_C = " - Destination*" Public Const CAR_SUP_A = "[FORWARD]" Public Const CAR_SUP_B = "Source:" Public Const CAR_SUP_C = "LAN" Public Const CAR_SUP_D = "," Public Const CAR_SUP_E = "Destination:" Public message As String Public Const ADR_MAIL = "nom@domaine.fr" Public Const OBJ_MAIL = "NETGEAR Security Log [57:5A:C2]" Public Const DOSSIER_ANALYSE = 6 'Correspond à la boite de réception 'Lance la récupération du corps du message Sub RecuperationCorpsMsg() ConnexionOutlook End Sub 'Connexion à Outlook Sub ConnexionOutlook() Dim co_outlookapp As Object Dim co_olnomdomaine As Object Dim co_oldossier As Object Dim co_olmailitem As Object Dim co_flgoutlook As Boolean Dim co_orderinfo As String Dim co_cheminfichier As String Dim co_flgfic As Boolean co_flgfic = False co_flgoutlook = False co_orderinfo = "" co_cheminfichier = "" ' Test de l'ouverture d'Outlook Set co_outlookapp = CreateObject("Outlook.Application") If co_outlookapp.Explorers.Count = 0 Then co_flgoutlook = True End If ' Création du répertoire Creation_Repertoire (REP_FICHIER) ' Test si fichier Excel existe Set xl_app = GetObject(, "Excel.Application") co_cheminfichier = REP_FICHIER & "" & NOM_FICHIER & EXT_FICHIER If ExistFile(co_cheminfichier) Then ' Test si fichier ouvert co_cheminfichier = NOM_FICHIER & EXT_FICHIER If Fic_ouvert(co_cheminfichier) Then Set xl_book = xl_app.Workbooks.Open(co_cheminfichier) co_flgfic = True Else MsgBox "Le fichier Excel est déjà ouvert.", vbOKOnly + vbCritical, _ "Tentative d'ouverture du fichier Excel" co_flgfic = True 'End If Else 'Procédure de création du fichier excel. Creation_Mise_en_forme_Fichier_Excel MsgBox "Le fichier Excel que vous souhaitiez ouvrir n'existait pas, il vient donc d'être créé.", _ vbOKOnly + vbInformation, "Test de l'existence du fichier Excel" co_flgfic = True End If If co_flgfic Then 'Permet l'accès aux données stockées Outlook de l'utilisateur Set co_olnomdomaine = co_outlookapp.GetNamespace("MAPI") 'Indique quel dossier doit être traité, ici le dossier contenant les emails utiles de la boite de réception Set co_oldossier = co_olnomdomaine.GetDefaultFolder(DOSSIER_ANALYSE) 'Boucle permettant de traiter tout les messages de la boite de réception For Each co_olmailitem In co_oldossier.Items 'Si l'objet du mail et l'adresse de l'expéditeur corresponddent, If Trim(co_olmailitem.Subject) OBJ_MAIL And Trim(co_olmailitem.SenderEmailAddress) ADR_MAIL Then 'Si il ne s'agit pas d'un message déjà lu et traité If co_olmailitem.UnRead = True Then 'Et si le corps du message n'est pas vide If co_olmailitem.Body <> vbNullString Then co_orderinfo = co_olmailitem.Body 'On fait appel à la procédure intégrant les informations dans le fichier Excel InsertIntoExcel (co_orderinfo) 'On indique que le message est lu co_olmailitem.UnRead = False End If End If End If Next If co_orderinfo = "" Then MsgBox "Il n'y aucune information à traiter !", _ vbOKOnly + vbInformation, "Enregistrement des Accès Internet" Else MsgBox "Toutes les informations ont été enregistrées dans le fichier Excel !", _ vbOKOnly + vbInformation, "Enregistrement des Accès Internet" End If End If 'Si on avai lancé une instance Outlook on la ferme If co_flgoutlook Then co_outlookapp.Quit End If 'On décharge les objets en mémoire Set co_oldossier = Nothing Set co_olnomdomaine = Nothing Set co_olmailitem = Nothing Set co_outlookapp = Nothing Set xl_app = Nothing Set xl_book = Nothing End Sub
'Procédure permettant le traitement du message, et l'insertion dans le fichier Excel Sub InsertIntoExcel(ByVal message As String) Dim myarray() As String, myarrayb() As String, _ myarrayc() As String, myarrayd() As String, _ myarraye() As String, myarrayf() As String Dim cheminfic As String Dim i As Integer, _ m As Integer, n As Integer, o As Integer Dim j As Integer, k As Integer, l As Integer Dim x As Byte, y As Byte Dim cel As Range, laplage As Range 'Initialisation des variables cheminfic = "" m = 0 n = 0 o = 0 cheminfic = REP_FICHIER 'On ouvre le fichier Excel If Fic_ouvert(cheminfic) Then Set xl_book = xl_app.Workbooks.Open(cheminfic) End If 'Split de message avec comme paramètre "WAN" et stockage dans le tableau myArray myarray = Split(message, SEP_MSG_A) 'Pour chaque ligne récupérée dans le tableau pendant le traitement du message For i = 0 To UBound(myarray()) 'Si il s'agit d'un site à accès bloqué, on insère la ligne dans le tableau myArrayB, If myarray(i) Like TYP_STR_A Then ReDim Preserve myarrayb(0 To m) myarrayb(m) = ReplaceStr(myarray(i)) m = m + 1 'Sinon, si il s'agit d'un accès autorisé, on récupère le début de la chaine dans le tableau myArrayD ElseIf myarray(i) Like TYP_STR_B Then ReDim Preserve myarrayd(0 To n) myarrayd(n) = ReplaceStr(myarray(i)) n = n + 1 'et on récupère la fin de cette chaine dans le tableau myArrayE (à cause de la précense des 2 "WAN" 'dans les chaines représentant un accès autorisé ElseIf myarray(i) Like TYP_STR_C Then ReDim Preserve myarraye(0 To o) myarraye(o) = ReplaceStr(myarray(i)) o = o + 1 End If Next i With xl_book.Worksheets(1) 'Split de chaque ligne de myArrayB avec comme paramètre " - " et stockage dans le tableau myArrayC For j = 0 To UBound(myarrayb()) myarrayc = Split(myarrayb(j), SEP_MSG_B) ReDim Preserve myarrayc(0 To UBound(myarrayc())) .Range("A" & j + .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, UBound(myarrayc()) + 1) = myarrayc Next j 'Split de chaque ligne de myArrayD associé à myArrayE avec comme paramètre " - " et stockage dans le tableau myArrayF For k = 0 To UBound(myarrayd()) myarrayf = Split(myarrayd(k) & myarraye(k), SEP_MSG_B) ReDim Preserve myarrayf(0 To UBound(myarrayf())) .Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myarrayf()) + 1) = myarrayf Next k 'Suppression Cellules Vides & Mise en forme For l = 2 To .Cells(Rows.Count, 2).End(xlUp).Row With .Cells(l, 2) If .Offset(0, -1).Text = "" Then .Offset(0, -1).Delete xlToLeft End If End With Next 'Permet la suppresion du jour (ex : "Mon") pour n'avoir que la date Set laplage = .Range("A2:A" & .Cells(Rows.Count, 2).End(xlUp).Row) For Each cel In laplage For x = 1 To Len(cel) If IsNumeric(Mid(cel, x, 1)) Then y = x Exit For End If Next x cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1)) Next cel End With 'Destruction des tableaux dynamiques Erase myarray Erase myarrayb Erase myarrayc Erase myarrayd Erase myarraye Erase myarrayf 'On décharge les objets en mémoire Set xl_app = Nothing Set xl_book = Nothing Set xl_sheet = Nothing End Sub 'Fonction permettant de supprimer les informations inutiles Function ReplaceStr(strch As String) As String Dim replacestr1 As String, replacestr2 As String, replacestr3 As String, replacestr4 As String replacestr1 = Replace(strch, CAR_SUP_A, "") replacestr2 = Replace(replacestr1, CAR_SUP_B, "") replacestr3 = Replace(replacestr2, CAR_SUP_C, "") replacestr4 = Replace(replacestr3, CAR_SUP_D, " ") ReplaceStr = Replace(replacestr4, CAR_SUP_E, "") End Function
cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1))
Option Explicit Sub EssaiExtractInfo2() Dim strChaine As String strChaine = "Mon, 2009-10-26 09:08:54 - Access site - Source:10.120.128.2,WAN - Destination:liveupdate.symantecliveupdate.com,WAN - [Forward] Mon, 2009-10-26 09:10:46 - Access site - Source:10.120.128.2,WAN - Destination:mm.123cmail.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/picto/fr/90x90tth.gif,WAN Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:ads.leadium.com,WAN - [Forward] Mon, 2009-10-26 09:10:47 - Access site - Source:10.120.128.2,WAN - Destination:wm.wizzms.com,WAN - [Forward] Mon, 2009-10-26 09:11:37 - Access site - Source:10.120.128.2,WAN - Destination:c.astrocenter.fr,WAN - [Forward] Mon, 2009-10-26 09:11:38 - Attempt to access blocked sites - Source:10.120.128.2,LAN - Destination:yahoo.astrocenter.fr/imgmails/bigpicto/fr/300x250_fr2k2.jpg,WAN" InsertIntoExcel (strChaine) End Sub 'Procédure permettant le traitement du message, et l'insertion dans le fichier Excel Sub InsertIntoExcel(ByVal message As String) Dim myArray() As String, myArrayB() As String, _ myArrayC() As String, myArrayD() As String, _ myArrayE() As String, myArrayF() As String, _ myArrayG() As String, myArrayH() As String Dim xlApp As Excel.Application Dim xl_Book As Excel.Workbook Dim xl_Sheet As Excel.Worksheet Dim xlApp_Cree As Boolean Dim xl_Book_Cree As Boolean Dim cheminFic As String Dim i As Integer, _ m As Integer, n As Integer, o As Integer, p As Integer Dim j As Integer, k As Integer, l As Integer Dim q As Integer Dim x As Byte, y As Byte Dim cel As Range, laPlage As Range 'Initialisation des variables cheminFic = "" m = 0 n = 0 o = 0 p = 0 'Evite le message d'erreur lors du test de l'existence de l'instance Excel On Error Resume Next 'Test l'existence d'une instance Excel Set xlApp = GetObject(, "Excel.Application") 'Si il n'y en a pas on la crée If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application") xlApp_Cree = True Else xl_Book_Cree = True End If On Error GoTo 0 'On ouvre le fichier Excel cheminFic = "D:\GARNIER\FG\Application\Rapport\Rapport_.xls" Set xl_Book = xlApp.Workbooks.Open(cheminFic) Set xl_Sheet = xl_Book.ActiveSheet 'Split de message avec comme paramètre "WAN" et stockage dans le tableau myArray myArray = Split(message, "WAN") 'Pour chaque ligne récupérée dans le tableau pendant le traitement du message For i = 0 To UBound(myArray()) 'Si il s'agit d'un site à accès bloqué, on insère la ligne dans le tableau myArrayB, If myArray(i) Like "*blocked*" Then ReDim Preserve myArrayB(0 To m) myArrayB(m) = ReplaceStr(myArray(i)) m = m + 1 'Sinon, si il s'agit d'un accès autorisé, on récupère le début de la chaine dans le tableau myArrayD ElseIf myArray(i) Like "*Access site*" Then ReDim Preserve myArrayD(0 To n) myArrayD(n) = ReplaceStr(myArray(i)) n = n + 1 'et on récupère la fin de cette chaine dans le tableau myArrayE (à cause de la précense des 2 "WAN" 'dans les chaines représentant un accès autorisé ElseIf myArray(i) Like " - Destination*" Then ReDim Preserve myArrayE(0 To o) myArrayE(o) = ReplaceStr(myArray(i)) o = o + 1 ElseIf myArray(i) Like "*IP packet*" Then ReDim Preserve myArrayG(0 To p) myArrayG(p) = ReplaceStr(myArray(i)) p = p + 1 End If Next i With xl_Sheet 'Split de chaque ligne de myArrayB avec comme paramètre " - " et stockage dans le tableau myArrayC For j = 0 To UBound(myArrayB()) myArrayC = Split(myArrayB(j), " - ") ReDim Preserve myArrayC(0 To UBound(myArrayC())) .Range("A" & j + .Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(, UBound(myArrayC()) + 1) = myArrayC Next j 'Split de chaque ligne de myArrayD associé à myArrayE avec comme paramètre " - " et stockage dans le tableau myArrayF For k = 0 To UBound(myArrayD()) myArrayF = Split(myArrayD(k) & myArrayE(k), " - ") ReDim Preserve myArrayF(0 To UBound(myArrayF())) .Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myArrayF()) + 1) = myArrayF Next k For q = 0 To UBound(myArrayG()) myArrayH = Split(myArrayG(q), " - ") ReDim Preserve myArrayH(0 To UBound(myArrayH())) .Range("A" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).Resize(, UBound(myArrayH()) + 1) = myArrayH Next q 'Suppression Cellules Vides & Mise en forme For l = 2 To .Cells(Rows.Count, 2).End(xlUp).Row With .Cells(l, 2) If .Offset(0, -1).Text = "" Then .Offset(0, -1).Delete xlToLeft End If End With Next 'Permet la suppresion du jour (ex : "Mon") pour n'avoir que la date Set laPlage = .Range("A2:A" & .Cells(Rows.Count, 2).End(xlUp).Row) For Each cel In laPlage For x = 1 To Len(cel) If IsNumeric(Mid(cel, x, 1)) Then y = x Exit For End If Next x 'Pb depuis l'ajout de l'ouverture du fichier If Len(cel) <> 0 Then cel.Value = CDate(Mid(cel.Text, y, Len(cel) - y + 1)) End If Next cel End With 'Destruction des tableaux dynamiques Erase myArray Erase myArrayB Erase myArrayC Erase myArrayD Erase myArrayE Erase myArrayF 'Si on avai lancé une instance Excel on la ferme If xlApp_Cree Then xlApp.Quit ElseIf xl_Book_Cree Then xl_Book.Close End If 'On décharge les objets en mémoire Set xlApp = Nothing Set xl_Book = Nothing Set xl_Sheet = Nothing End Sub 'Fonction permettant de supprimer les informations inutiles Function ReplaceStr(strCh As String) As String Dim replaceStr1 As String, replaceStr2 As String, replaceStr3 As String, replaceStr4 As String, replaceStr5 As String replaceStr1 = Replace(strCh, "[Forward]", "") replaceStr2 = Replace(replaceStr1, "Source:", "") replaceStr3 = Replace(replaceStr2, "LAN", "") replaceStr4 = Replace(replaceStr3, ",", " ") replaceStr5 = Replace(replaceStr4, "Destination:", "") ReplaceStr = Replace(replaceStr5, " [Drop] - [Targa3 Attack] ", "") End Function